diff options
| author | Johannes Ranke <jranke@uni-bremen.de> | 2021-07-29 12:17:56 +0200 |
|---|---|---|
| committer | Johannes Ranke <jranke@uni-bremen.de> | 2021-07-29 12:17:56 +0200 |
| commit | 137612045c23198f10d6e8612c32e266c2a6c00e (patch) | |
| tree | 7cc4df88626f81cfacc0e5613169429c18d7515d | |
| parent | 4b1eb3687645fd0d502e01d0df0ae0a704110806 (diff) | |
Go back to 1.0.x version, update docs
25 files changed, 103 insertions, 95 deletions
diff --git a/DESCRIPTION b/DESCRIPTION index 4689cb2a..2364ee75 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,8 +1,8 @@ Package: mkin Type: Package Title: Kinetic Evaluation of Chemical Degradation Data -Version: 1.1.0 -Date: 2021-06-23 +Version: 1.0.5 +Date: 2021-07-29 Authors@R: c( person("Johannes", "Ranke", role = c("aut", "cre", "cph"), email = "jranke@uni-bremen.de", @@ -10,6 +10,8 @@ - 'plot.mixed.mmkin': Gains arguments 'test_log_parms' and 'conf.level' +- 'vignettes/web_only/dimethenamid_2018.rmd': Example evaluations of the dimethenamid data. + # mkin 1.0.4 (2021-04-20) - All plotting functions setting graphical parameters: Use on.exit() for resetting graphical parameters diff --git a/docs/dev/404.html b/docs/dev/404.html index 38898979..98c0b1e0 100644 --- a/docs/dev/404.html +++ b/docs/dev/404.html @@ -71,7 +71,7 @@ </button> <span class="navbar-brand"> <a class="navbar-link" href="https://pkgdown.jrwb.de/mkin/index.html">mkin</a> - <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.1.0</span> + <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.0.5</span> </span> </div> diff --git a/docs/dev/articles/index.html b/docs/dev/articles/index.html index c0338df8..99ce950b 100644 --- a/docs/dev/articles/index.html +++ b/docs/dev/articles/index.html @@ -71,7 +71,7 @@ </button> <span class="navbar-brand"> <a class="navbar-link" href="../index.html">mkin</a> - <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.1.0</span> + <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.0.5</span> </span> </div> diff --git a/docs/dev/articles/web_only/dimethenamid_2018.html b/docs/dev/articles/web_only/dimethenamid_2018.html index 7648f75a..34d882a4 100644 --- a/docs/dev/articles/web_only/dimethenamid_2018.html +++ b/docs/dev/articles/web_only/dimethenamid_2018.html @@ -32,7 +32,7 @@ </button> <span class="navbar-brand"> <a class="navbar-link" href="../../index.html">mkin</a> - <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.1.0</span> + <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.0.5</span> </span> </div> @@ -101,7 +101,7 @@ <h1 data-toc-skip>Example evaluations of the dimethenamid data from 2018</h1> <h4 class="author">Johannes Ranke</h4> - <h4 class="date">Last change 27 July 2021, built on 27 Jul 2021</h4> + <h4 class="date">Last change 27 July 2021, built on 29 Jul 2021</h4> <small class="dont-index">Source: <a href="https://github.com/jranke/mkin/blob/master/vignettes/web_only/dimethenamid_2018.rmd"><code>vignettes/web_only/dimethenamid_2018.rmd</code></a></small> <div class="hidden name"><code>dimethenamid_2018.rmd</code></div> @@ -154,20 +154,20 @@ error_model <span class="op">=</span> <span class="st">"tc"</span>, quiet <span class="op">=</span> <span class="cn">TRUE</span><span class="op">)</span></code></pre></div> <p>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):</p> <div class="sourceCode" id="cb3"><pre class="downlit sourceCode r"> -<code class="sourceCode R"><span class="fu"><a href="https://rdrr.io/r/graphics/plot.default.html">plot</a></span><span class="op">(</span><span class="fu"><a href="../../reference/mixed.html">mixed</a></span><span class="op">(</span><span class="va">f_parent_mkin_const</span><span class="op">[</span><span class="st">"SFO"</span>, <span class="op">]</span><span class="op">)</span><span class="op">)</span></code></pre></div> +<code class="sourceCode R"><span class="fu"><a href="https://rdrr.io/pkg/saemix/man/plot-SaemixObject-method.html">plot</a></span><span class="op">(</span><span class="fu"><a href="../../reference/mixed.html">mixed</a></span><span class="op">(</span><span class="va">f_parent_mkin_const</span><span class="op">[</span><span class="st">"SFO"</span>, <span class="op">]</span><span class="op">)</span><span class="op">)</span></code></pre></div> <p><img src="dimethenamid_2018_files/figure-html/f_parent_mkin_sfo_const-1.png" width="700"></p> <p>Using biexponential decline (DFOP) results in a slightly more random scatter of the residuals:</p> <div class="sourceCode" id="cb4"><pre class="downlit sourceCode r"> -<code class="sourceCode R"><span class="fu"><a href="https://rdrr.io/r/graphics/plot.default.html">plot</a></span><span class="op">(</span><span class="fu"><a href="../../reference/mixed.html">mixed</a></span><span class="op">(</span><span class="va">f_parent_mkin_const</span><span class="op">[</span><span class="st">"DFOP"</span>, <span class="op">]</span><span class="op">)</span><span class="op">)</span></code></pre></div> +<code class="sourceCode R"><span class="fu"><a href="https://rdrr.io/pkg/saemix/man/plot-SaemixObject-method.html">plot</a></span><span class="op">(</span><span class="fu"><a href="../../reference/mixed.html">mixed</a></span><span class="op">(</span><span class="va">f_parent_mkin_const</span><span class="op">[</span><span class="st">"DFOP"</span>, <span class="op">]</span><span class="op">)</span><span class="op">)</span></code></pre></div> <p><img src="dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_const-1.png" width="700"></p> <p>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:</p> <div class="sourceCode" id="cb5"><pre class="downlit sourceCode r"> -<code class="sourceCode R"><span class="fu"><a href="https://rdrr.io/r/graphics/plot.default.html">plot</a></span><span class="op">(</span><span class="fu"><a href="../../reference/mixed.html">mixed</a></span><span class="op">(</span><span class="va">f_parent_mkin_const</span><span class="op">[</span><span class="st">"DFOP"</span>, <span class="op">]</span><span class="op">)</span>, test_log_parms <span class="op">=</span> <span class="cn">TRUE</span><span class="op">)</span></code></pre></div> +<code class="sourceCode R"><span class="fu"><a href="https://rdrr.io/pkg/saemix/man/plot-SaemixObject-method.html">plot</a></span><span class="op">(</span><span class="fu"><a href="../../reference/mixed.html">mixed</a></span><span class="op">(</span><span class="va">f_parent_mkin_const</span><span class="op">[</span><span class="st">"DFOP"</span>, <span class="op">]</span><span class="op">)</span>, test_log_parms <span class="op">=</span> <span class="cn">TRUE</span><span class="op">)</span></code></pre></div> <p><img src="dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_const_test-1.png" width="700"></p> <p>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).</p> <p>The remaining trend of the residuals to be higher for higher predicted residues is reduced by using the two-component error model:</p> <div class="sourceCode" id="cb6"><pre class="downlit sourceCode r"> -<code class="sourceCode R"><span class="fu"><a href="https://rdrr.io/r/graphics/plot.default.html">plot</a></span><span class="op">(</span><span class="fu"><a href="../../reference/mixed.html">mixed</a></span><span class="op">(</span><span class="va">f_parent_mkin_tc</span><span class="op">[</span><span class="st">"DFOP"</span>, <span class="op">]</span><span class="op">)</span>, test_log_parms <span class="op">=</span> <span class="cn">TRUE</span><span class="op">)</span></code></pre></div> +<code class="sourceCode R"><span class="fu"><a href="https://rdrr.io/pkg/saemix/man/plot-SaemixObject-method.html">plot</a></span><span class="op">(</span><span class="fu"><a href="../../reference/mixed.html">mixed</a></span><span class="op">(</span><span class="va">f_parent_mkin_tc</span><span class="op">[</span><span class="st">"DFOP"</span>, <span class="op">]</span><span class="op">)</span>, test_log_parms <span class="op">=</span> <span class="cn">TRUE</span><span class="op">)</span></code></pre></div> <p><img src="dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_tc_test-1.png" width="700"></p> </div> <div id="nonlinear-mixed-effects-models" class="section level2"> @@ -205,7 +205,7 @@ 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</code></pre> <p>The selected model (DFOP with two-component error) fitted to the data assuming no correlations between random effects is shown below.</p> <div class="sourceCode" id="cb11"><pre class="downlit sourceCode r"> -<code class="sourceCode R"><span class="fu"><a href="https://rdrr.io/r/graphics/plot.default.html">plot</a></span><span class="op">(</span><span class="va">f_parent_nlme_dfop_tc</span><span class="op">)</span></code></pre></div> +<code class="sourceCode R"><span class="fu"><a href="https://rdrr.io/pkg/saemix/man/plot-SaemixObject-method.html">plot</a></span><span class="op">(</span><span class="va">f_parent_nlme_dfop_tc</span><span class="op">)</span></code></pre></div> <p><img src="dimethenamid_2018_files/figure-html/plot_parent_nlme-1.png" width="700"></p> </div> <div id="saemix" class="section level3"> diff --git a/docs/dev/authors.html b/docs/dev/authors.html index 943cba1b..4208dc24 100644 --- a/docs/dev/authors.html +++ b/docs/dev/authors.html @@ -71,7 +71,7 @@ </button> <span class="navbar-brand"> <a class="navbar-link" href="index.html">mkin</a> - <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.1.0</span> + <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.0.5</span> </span> </div> diff --git a/docs/dev/index.html b/docs/dev/index.html index 8049b3a1..ddfce971 100644 --- a/docs/dev/index.html +++ b/docs/dev/index.html @@ -38,7 +38,7 @@ </button> <span class="navbar-brand"> <a class="navbar-link" href="index.html">mkin</a> - <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.1.0</span> + <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.0.5</span> </span> </div> @@ -206,6 +206,11 @@ <table class="table"> <tr> <td> +Ranke J, Wöltjen J, Schmidt J, and Comets E (2021) Taking kinetic evaluations of degradation data to the next level with nonlinear mixed-effects models. <i>Environments</i> <b>8</b> (8) 71 <a href="https://doi.org/10.3390/environments8080071">doi:10.3390/environments8080071</a> +</td> +</tr> +<tr> +<td> Ranke J, Meinecke S (2019) Error Models for the Kinetic Evaluation of Chemical Degradation Data <i>Environments</i> <b>6</b> (12) 124 <a href="https://doi.org/10.3390/environments6120124">doi:10.3390/environments6120124</a> </td> </tr> diff --git a/docs/dev/news/index.html b/docs/dev/news/index.html index cfe577cf..5b153f37 100644 --- a/docs/dev/news/index.html +++ b/docs/dev/news/index.html @@ -71,7 +71,7 @@ </button> <span class="navbar-brand"> <a class="navbar-link" href="../index.html">mkin</a> - <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.1.0</span> + <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.0.5</span> </span> </div> @@ -152,6 +152,7 @@ <li><p>Reintroduce the interface to current development versions (not on CRAN) of saemix, in particular the generic function ‘saem’ with a generator ‘saem.mmkin’, currently using ‘saemix_model’ and ‘saemix_data’, summary and plot methods</p></li> <li><p>‘mean_degparms’: New argument ‘test_log_parms’ that makes the function only consider log-transformed parameters where the untransformed parameters pass the t-test for a certain confidence level. This can be used to obtain more plausible starting parameters for the different mixed-effects model backends</p></li> <li><p>‘plot.mixed.mmkin’: Gains arguments ‘test_log_parms’ and ‘conf.level’</p></li> +<li><p>‘vignettes/web_only/dimethenamid_2018.rmd’: Example evaluations of the dimethenamid data.</p></li> </ul> </div> </div> diff --git a/docs/dev/pkgdown.yml b/docs/dev/pkgdown.yml index 16f7f0d6..ab5aae58 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-27T15:54Z +last_built: 2021-07-29T09:41Z urls: reference: https://pkgdown.jrwb.de/mkin/reference article: https://pkgdown.jrwb.de/mkin/articles diff --git a/docs/dev/reference/dimethenamid_2018.html b/docs/dev/reference/dimethenamid_2018.html index 160dcaa3..c893da63 100644 --- a/docs/dev/reference/dimethenamid_2018.html +++ b/docs/dev/reference/dimethenamid_2018.html @@ -77,7 +77,7 @@ constrained by data protection regulations." /> </button> <span class="navbar-brand"> <a class="navbar-link" href="../index.html">mkin</a> - <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.1.0</span> + <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.0.5</span> </span> </div> @@ -295,7 +295,7 @@ specific pieces of information in the comments.</p> #> M31 ~ add(sigma_low_M31) + prop(rsd_high_M31) #> }) #> } -#> <environment: 0x555559c00ce8></div><div class='input'><span class='co'># The focei fit takes about four minutes on my system</span> +#> <environment: 0x555559bfc940></div><div class='input'><span class='co'># The focei fit takes about four minutes on my system</span> <span class='fu'><a href='https://rdrr.io/r/base/system.time.html'>system.time</a></span><span class='op'>(</span> <span class='va'>f_dmta_nlmixr_focei</span> <span class='op'><-</span> <span class='fu'><a href='https://rdrr.io/pkg/nlmixr/man/nlmixr.html'>nlmixr</a></span><span class='op'>(</span><span class='va'>f_dmta_mkin_tc</span>, est <span class='op'>=</span> <span class='st'>"focei"</span>, control <span class='op'>=</span> <span class='fu'>nlmixr</span><span class='fu'>::</span><span class='fu'><a href='https://rdrr.io/pkg/nlmixr/man/foceiControl.html'>foceiControl</a></span><span class='op'>(</span>print <span class='op'>=</span> <span class='fl'>500</span><span class='op'>)</span><span class='op'>)</span> @@ -303,7 +303,7 @@ specific pieces of information in the comments.</p> </div><div class='output co'>#> <span class='message'><span style='color: #00BBBB;'>ℹ</span> parameter labels from comments are typically ignored in non-interactive mode</span></div><div class='output co'>#> <span class='message'><span style='color: #00BBBB;'>ℹ</span> Need to run with the source intact to parse comments</span></div><div class='output co'>#> <span class='message'>→ creating full model...</span></div><div class='output co'>#> <span class='message'>→ pruning branches (<span style='color: #262626; background-color: #DADADA;'>`if`</span>/<span style='color: #262626; background-color: #DADADA;'>`else`</span>)...</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ loading into <span style='color: #0000BB;'>symengine</span> environment...</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ creating full model...</span></div><div class='output co'>#> <span class='message'>→ pruning branches (<span style='color: #262626; background-color: #DADADA;'>`if`</span>/<span style='color: #262626; background-color: #DADADA;'>`else`</span>)...</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ loading into <span style='color: #0000BB;'>symengine</span> environment...</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ calculate jacobian</span></div><div class='output co'>#> [====|====|====|====|====|====|====|====|====|====] 0:00:02 #> </div><div class='output co'>#> <span class='message'>→ calculate sensitivities</span></div><div class='output co'>#> [====|====|====|====|====|====|====|====|====|====] 0:00:04 #> </div><div class='output co'>#> <span class='message'>→ calculate ∂(f)/∂(η)</span></div><div class='output co'>#> [====|====|====|====|====|====|====|====|====|====] 0:00:01 -#> </div><div class='output co'>#> <span class='message'>→ calculate ∂(R²)/∂(η)</span></div><div class='output co'>#> [====|====|====|====|====|====|====|====|====|====] 0:00:08 +#> </div><div class='output co'>#> <span class='message'>→ calculate ∂(R²)/∂(η)</span></div><div class='output co'>#> [====|====|====|====|====|====|====|====|====|====] 0:00:09 #> </div><div class='output co'>#> <span class='message'>→ finding duplicate expressions in inner model...</span></div><div class='output co'>#> [====|====|====|====|====|====|====|====|====|====] 0:00:07 #> </div><div class='output co'>#> <span class='message'>→ optimizing duplicate expressions in inner model...</span></div><div class='output co'>#> [====|====|====|====|====|====|====|====|====|====] 0:00:07 #> </div><div class='output co'>#> <span class='message'>→ finding duplicate expressions in EBE model...</span></div><div class='output co'>#> [====|====|====|====|====|====|====|====|====|====] 0:00:00 @@ -324,12 +324,12 @@ specific pieces of information in the comments.</p> #> <span style='text-decoration: underline;'>|.....................| o9 | o10 |...........|...........|</span> #> calculating covariance matrix #> done</div><div class='output co'>#> <span class='message'>Calculating residuals/tables</span></div><div class='output co'>#> <span class='message'>done</span></div><div class='output co'>#> <span class='warning'>Warning: initial ETAs were nudged; (can control by foceiControl(etaNudge=., etaNudge2=))</span></div><div class='output co'>#> <span class='warning'>Warning: last objective function was not at minimum, possible problems in optimization</span></div><div class='output co'>#> <span class='warning'>Warning: S matrix non-positive definite</span></div><div class='output co'>#> <span class='warning'>Warning: using R matrix to calculate covariance</span></div><div class='output co'>#> <span class='warning'>Warning: gradient problems with initial estimate and covariance; see $scaleInfo</span></div><div class='output co'>#> user system elapsed -#> 227.879 9.742 237.728 </div><div class='input'><span class='fu'><a href='https://rdrr.io/r/base/summary.html'>summary</a></span><span class='op'>(</span><span class='va'>f_dmta_nlmixr_focei</span><span class='op'>)</span> +#> 227.223 8.444 235.624 </div><div class='input'><span class='fu'><a href='https://rdrr.io/r/base/summary.html'>summary</a></span><span class='op'>(</span><span class='va'>f_dmta_nlmixr_focei</span><span class='op'>)</span> </div><div class='output co'>#> nlmixr version used for fitting: 2.0.4 -#> mkin version used for pre-fitting: 1.1.0 +#> mkin version used for pre-fitting: 1.0.5 #> R version used for fitting: 4.1.0 -#> Date of fit: Tue Jul 27 16:02:33 2021 -#> Date of summary: Tue Jul 27 16:02:34 2021 +#> Date of fit: Thu Jul 29 11:45:46 2021 +#> Date of summary: Thu Jul 29 11:45:46 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.</p> #> #> Degradation model predictions using RxODE #> -#> Fitted in 237.547 s +#> Fitted in 235.457 s #> #> Variance model: Two-component variance function #> @@ -489,11 +489,11 @@ specific pieces of information in the comments.</p> <span class='va'>f_dmta_saemix</span> <span class='op'><-</span> <span class='fu'><a href='saem.html'>saem</a></span><span class='op'>(</span><span class='va'>f_dmta_mkin_tc</span>, test_log_parms <span class='op'>=</span> <span class='cn'>TRUE</span><span class='op'>)</span> <span class='op'>)</span> </div><div class='output co'>#> Running main SAEM algorithm -#> [1] "Tue Jul 27 16:02:34 2021" +#> [1] "Thu Jul 29 11:45:47 2021" #> .... #> Minimisation finished -#> [1] "Tue Jul 27 16:21:39 2021"</div><div class='output co'>#> user system elapsed -#> 1213.394 0.087 1213.578 </div><div class='input'> +#> [1] "Thu Jul 29 12:04:25 2021"</div><div class='output co'>#> user system elapsed +#> 1185.594 0.028 1185.687 </div><div class='input'> <span class='co'># nlmixr with est = "saem" is pretty fast with default iteration numbers, most</span> <span class='co'># of the time (about 2.5 minutes) is spent for calculating the log likelihood at the end</span> <span class='co'># The likelihood calculated for the nlmixr fit is much lower than that found by saemix</span> @@ -506,13 +506,13 @@ specific pieces of information in the comments.</p> <span class='op'>)</span> </div><div class='output co'>#> <span class='message'>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)</span></div><div class='output co'>#> <span class='message'><span style='color: #00BBBB;'>ℹ</span> parameter labels from comments are typically ignored in non-interactive mode</span></div><div class='output co'>#> <span class='message'><span style='color: #00BBBB;'>ℹ</span> Need to run with the source intact to parse comments</span></div><div class='output co'>#> <span class='message'> </span></div><div class='output co'>#> <span class='message'>→ generate SAEM model</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> 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</div><div class='output co'>#> <span class='message'>Calculating covariance matrix</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>Calculating -2LL by Gaussian quadrature (nnodes=3,nsd=1.6)</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ creating full model...</span></div><div class='output co'>#> <span class='message'>→ pruning branches (<span style='color: #262626; background-color: #DADADA;'>`if`</span>/<span style='color: #262626; background-color: #DADADA;'>`else`</span>)...</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ loading into <span style='color: #0000BB;'>symengine</span> environment...</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ compiling EBE model...</span></div><div class='output co'>#> <span class='message'> </span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>Needed Covariates:</span></div><div class='output co'>#> [1] "CMT"</div><div class='output co'>#> <span class='message'>Calculating residuals/tables</span></div><div class='output co'>#> <span class='message'>done</span></div><div class='output co'>#> user system elapsed -#> 818.782 3.808 154.926 </div><div class='input'><span class='fu'>traceplot</span><span class='op'>(</span><span class='va'>f_dmta_nlmixr_saem</span><span class='op'>$</span><span class='va'>nm</span><span class='op'>)</span> +#> 809.956 4.286 156.438 </div><div class='input'><span class='fu'>traceplot</span><span class='op'>(</span><span class='va'>f_dmta_nlmixr_saem</span><span class='op'>$</span><span class='va'>nm</span><span class='op'>)</span> </div><div class='output co'>#> <span class='error'>Error in traceplot(f_dmta_nlmixr_saem$nm): could not find function "traceplot"</span></div><div class='input'><span class='fu'><a href='https://rdrr.io/r/base/summary.html'>summary</a></span><span class='op'>(</span><span class='va'>f_dmta_nlmixr_saem</span><span class='op'>)</span> </div><div class='output co'>#> nlmixr version used for fitting: 2.0.4 -#> mkin version used for pre-fitting: 1.1.0 +#> mkin version used for pre-fitting: 1.0.5 #> 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 +#> Date of fit: Thu Jul 29 12:08:09 2021 +#> Date of summary: Thu Jul 29 12:08:09 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.</p> #> #> Degradation model predictions using RxODE #> -#> Fitted in 154.632 s +#> Fitted in 156.17 s #> #> Variance model: Two-component variance function #> diff --git a/docs/dev/reference/endpoints.html b/docs/dev/reference/endpoints.html index aa5bd773..dc1d1f17 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." /> </button> <span class="navbar-brand"> <a class="navbar-link" href="../index.html">mkin</a> - <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.1.0</span> + <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.0.5</span> </span> </div> diff --git a/docs/dev/reference/index.html b/docs/dev/reference/index.html index d5ec387a..bb030605 100644 --- a/docs/dev/reference/index.html +++ b/docs/dev/reference/index.html @@ -71,7 +71,7 @@ </button> <span class="navbar-brand"> <a class="navbar-link" href="../index.html">mkin</a> - <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.1.0</span> + <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.0.5</span> </span> </div> diff --git a/docs/dev/reference/mean_degparms.html b/docs/dev/reference/mean_degparms.html index 5981c625..f63dbc31 100644 --- a/docs/dev/reference/mean_degparms.html +++ b/docs/dev/reference/mean_degparms.html @@ -72,7 +72,7 @@ </button> <span class="navbar-brand"> <a class="navbar-link" href="../index.html">mkin</a> - <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.1.0</span> + <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.0.5</span> </span> </div> diff --git a/docs/dev/reference/mkinmod.html b/docs/dev/reference/mkinmod.html index e57e7062..5db8e719 100644 --- a/docs/dev/reference/mkinmod.html +++ b/docs/dev/reference/mkinmod.html @@ -76,7 +76,7 @@ components." /> </button> <span class="navbar-brand"> <a class="navbar-link" href="../index.html">mkin</a> - <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.1.0</span> + <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.0.5</span> </span> </div> @@ -344,7 +344,7 @@ Evaluating and Calculating Degradation Kinetics in Environmental Media</p> parent <span class='op'>=</span> <span class='fu'>mkinsub</span><span class='op'>(</span><span class='st'>"SFO"</span>, <span class='st'>"m1"</span>, full_name <span class='op'>=</span> <span class='st'>"Test compound"</span><span class='op'>)</span>, m1 <span class='op'>=</span> <span class='fu'>mkinsub</span><span class='op'>(</span><span class='st'>"SFO"</span>, full_name <span class='op'>=</span> <span class='st'>"Metabolite M1"</span><span class='op'>)</span>, name <span class='op'>=</span> <span class='st'>"SFO_SFO"</span>, dll_dir <span class='op'>=</span> <span class='va'>DLL_dir</span>, unload <span class='op'>=</span> <span class='cn'>TRUE</span>, overwrite <span class='op'>=</span> <span class='cn'>TRUE</span><span class='op'>)</span> -</div><div class='output co'>#> <span class='message'>Copied DLL from /tmp/RtmpPWWdbW/fileccff46a6d9773.so to /home/jranke/.local/share/mkin/SFO_SFO.so</span></div><div class='input'><span class='co'># Now we can save the model and restore it in a new session</span> +</div><div class='output co'>#> <span class='message'>Copied DLL from /tmp/Rtmpjz6gts/filefa69f342e9d9d.so to /home/jranke/.local/share/mkin/SFO_SFO.so</span></div><div class='input'><span class='co'># Now we can save the model and restore it in a new session</span> <span class='fu'><a href='https://rdrr.io/r/base/readRDS.html'>saveRDS</a></span><span class='op'>(</span><span class='va'>SFO_SFO.2</span>, file <span class='op'>=</span> <span class='st'>"~/SFO_SFO.rds"</span><span class='op'>)</span> <span class='co'># Terminate the R session here if you would like to check, and then do</span> <span class='kw'><a href='https://rdrr.io/r/base/library.html'>library</a></span><span class='op'>(</span><span class='va'><a href='https://pkgdown.jrwb.de/mkin/'>mkin</a></span><span class='op'>)</span> @@ -393,7 +393,7 @@ Evaluating and Calculating Degradation Kinetics in Environmental Media</p> #> }) #> return(predicted) #> } -#> <environment: 0x5555645abab8></div><div class='input'> +#> <environment: 0x55556283eae8></div><div class='input'> <span class='co'># If we have several parallel metabolites</span> <span class='co'># (compare tests/testthat/test_synthetic_data_for_UBA_2014.R)</span> <span class='va'>m_synth_DFOP_par</span> <span class='op'><-</span> <span class='fu'>mkinmod</span><span class='op'>(</span> diff --git a/docs/dev/reference/nlme-1.png b/docs/dev/reference/nlme-1.png Binary files differindex f739089a..365aaef0 100644 --- a/docs/dev/reference/nlme-1.png +++ b/docs/dev/reference/nlme-1.png diff --git a/docs/dev/reference/nlme-2.png b/docs/dev/reference/nlme-2.png Binary files differindex d3b29bb0..40841404 100644 --- a/docs/dev/reference/nlme-2.png +++ b/docs/dev/reference/nlme-2.png diff --git a/docs/dev/reference/nlme.html b/docs/dev/reference/nlme.html index 184585df..55a94443 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." /> </button> <span class="navbar-brand"> <a class="navbar-link" href="../index.html">mkin</a> - <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.1.0</span> + <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.0.5</span> </span> </div> @@ -216,28 +216,28 @@ datasets. They are used internally by the <code><a href='nlme.mmkin.html'>nlme.m #> Model: value ~ nlme_f(name, time, parent_0, log_k_parent_sink) #> Data: grouped_data #> AIC BIC logLik -#> 278.1355 287.7946 -134.0677 +#> 300.6824 310.2426 -145.3412 #> #> Random effects: #> Formula: list(parent_0 ~ 1, log_k_parent_sink ~ 1) #> Level: ds #> Structure: Diagonal #> parent_0 log_k_parent_sink Residual -#> StdDev: 3.406042 0.6437579 2.620833 +#> StdDev: 1.697361 0.6801209 3.666073 #> #> Fixed effects: parent_0 + log_k_parent_sink ~ 1 #> Value Std.Error DF t-value p-value -#> parent_0 101.50173 2.123709 47 47.79457 0 -#> log_k_parent_sink -3.07597 0.379775 47 -8.09945 0 +#> parent_0 100.99378 1.3890416 46 72.70753 0 +#> log_k_parent_sink -3.07521 0.4018589 46 -7.65246 0 #> Correlation: #> prnt_0 -#> log_k_parent_sink 0.01 +#> log_k_parent_sink 0.027 #> #> Standardized Within-Group Residuals: -#> Min Q1 Med Q3 Max -#> -2.06889303 -0.50100169 -0.06268253 0.62557544 2.19922001 +#> Min Q1 Med Q3 Max +#> -1.9942823 -0.5622565 0.1791579 0.7165038 2.0704781 #> -#> Number of Observations: 51 +#> Number of Observations: 50 #> Number of Groups: 3 </div><div class='input'><span class='fu'><a href='https://rdrr.io/r/graphics/plot.default.html'>plot</a></span><span class='op'>(</span><span class='fu'><a href='https://rdrr.io/pkg/nlme/man/augPred.html'>augPred</a></span><span class='op'>(</span><span class='va'>m_nlme</span>, level <span class='op'>=</span> <span class='fl'>0</span><span class='op'>:</span><span class='fl'>1</span><span class='op'>)</span>, layout <span class='op'>=</span> <span class='fu'><a href='https://rdrr.io/r/base/c.html'>c</a></span><span class='op'>(</span><span class='fl'>3</span>, <span class='fl'>1</span><span class='op'>)</span><span class='op'>)</span> </div><div class='img'><img src='nlme-1.png' alt='' width='700' height='433' /></div><div class='input'><span class='co'># augPred does not work on fits with more than one state</span> <span class='co'># variable</span> diff --git a/docs/dev/reference/nlme.mmkin.html b/docs/dev/reference/nlme.mmkin.html index 866091ca..db863392 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." /> </button> <span class="navbar-brand"> <a class="navbar-link" href="../index.html">mkin</a> - <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.1.0</span> + <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.0.5</span> </span> </div> diff --git a/docs/dev/reference/nlmixr.mmkin.html b/docs/dev/reference/nlmixr.mmkin.html index 328bad43..b7dfb9ca 100644 --- a/docs/dev/reference/nlmixr.mmkin.html +++ b/docs/dev/reference/nlmixr.mmkin.html @@ -74,7 +74,7 @@ Expectation Maximisation algorithm (SAEM)." /> </button> <span class="navbar-brand"> <a class="navbar-link" href="../index.html">mkin</a> - <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.1.0</span> + <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.0.5</span> </span> </div> @@ -4501,7 +4501,7 @@ obtained by fitting the same model to a list of datasets using <a href='mkinfit. #> <span class='message'>k_A1=rx_expr_11;</span> #> <span class='message'>f_parent=1/(1+exp(-(ETA[4]+THETA[4])));</span> #> <span class='message'>tad=tad();</span> -#> <span class='message'>dosenum=dosenum();</span></div><div class='output co'>#> <span class='message'>Needed Covariates:</span></div><div class='output co'>#> <span class='message'>[1] "f_parent_to_A1" "CMT" </span></div><div class='output co'>#> <span class='error'>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.</span></div><div class='output co'>#> <span class='message'>Timing stopped at: 5.548 0.415 5.961</span></div><div class='input'><span class='va'>f_nlmixr_fomc_sfo_focei_const</span> <span class='op'><-</span> <span class='fu'><a href='https://rdrr.io/pkg/nlmixr/man/nlmixr.html'>nlmixr</a></span><span class='op'>(</span><span class='va'>f_mmkin_const</span><span class='op'>[</span><span class='st'>"FOMC-SFO"</span>, <span class='op'>]</span>, est <span class='op'>=</span> <span class='st'>"focei"</span><span class='op'>)</span> +#> <span class='message'>dosenum=dosenum();</span></div><div class='output co'>#> <span class='message'>Needed Covariates:</span></div><div class='output co'>#> <span class='message'>[1] "f_parent_to_A1" "CMT" </span></div><div class='output co'>#> <span class='error'>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.</span></div><div class='output co'>#> <span class='message'>Timing stopped at: 5.801 0.369 6.185</span></div><div class='input'><span class='va'>f_nlmixr_fomc_sfo_focei_const</span> <span class='op'><-</span> <span class='fu'><a href='https://rdrr.io/pkg/nlmixr/man/nlmixr.html'>nlmixr</a></span><span class='op'>(</span><span class='va'>f_mmkin_const</span><span class='op'>[</span><span class='st'>"FOMC-SFO"</span>, <span class='op'>]</span>, est <span class='op'>=</span> <span class='st'>"focei"</span><span class='op'>)</span> </div><div class='output co'>#> <span class='message'><span style='color: #00BBBB;'>ℹ</span> parameter labels from comments are typically ignored in non-interactive mode</span></div><div class='output co'>#> <span class='message'><span style='color: #00BBBB;'>ℹ</span> Need to run with the source intact to parse comments</span></div><div class='output co'>#> <span class='message'>→ creating full model...</span></div><div class='output co'>#> <span class='message'>→ pruning branches (<span style='color: #262626; background-color: #DADADA;'>`if`</span>/<span style='color: #262626; background-color: #DADADA;'>`else`</span>)...</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ loading into <span style='color: #0000BB;'>symengine</span> environment...</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ creating full model...</span></div><div class='output co'>#> <span class='message'>→ pruning branches (<span style='color: #262626; background-color: #DADADA;'>`if`</span>/<span style='color: #262626; background-color: #DADADA;'>`else`</span>)...</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ loading into <span style='color: #0000BB;'>symengine</span> environment...</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ calculate jacobian</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ calculate sensitivities</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ calculate ∂(f)/∂(η)</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ calculate ∂(R²)/∂(η)</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ finding duplicate expressions in inner model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ optimizing duplicate expressions in inner model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ finding duplicate expressions in EBE model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ optimizing duplicate expressions in EBE model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ compiling inner model...</span></div><div class='output co'>#> <span class='message'> </span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ finding duplicate expressions in FD model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ optimizing duplicate expressions in FD model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ compiling EBE model...</span></div><div class='output co'>#> <span class='message'> </span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ compiling events FD model...</span></div><div class='output co'>#> <span class='message'> </span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>Model:</span></div><div class='output co'>#> <span class='message'>cmt(parent);</span> #> <span class='message'>cmt(A1);</span> #> <span class='message'>rx_expr_6~ETA[1]+THETA[1];</span> @@ -4550,7 +4550,7 @@ obtained by fitting the same model to a list of datasets using <a href='mkinfit. #> <span class='message'>beta=exp(rx_expr_8);</span> #> <span class='message'>f_parent=1/(1+exp(-(ETA[3]+THETA[3])));</span> #> <span class='message'>tad=tad();</span> -#> <span class='message'>dosenum=dosenum();</span></div><div class='output co'>#> <span class='message'>Needed Covariates:</span></div><div class='output co'>#> <span class='message'>[1] "f_parent_to_A1" "CMT" </span></div><div class='output co'>#> <span class='error'>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.</span></div><div class='output co'>#> <span class='message'>Timing stopped at: 6.895 0.416 7.309</span></div><div class='input'><span class='va'>f_nlmixr_dfop_sfo_focei_const</span> <span class='op'><-</span> <span class='fu'><a href='https://rdrr.io/pkg/nlmixr/man/nlmixr.html'>nlmixr</a></span><span class='op'>(</span><span class='va'>f_mmkin_const</span><span class='op'>[</span><span class='st'>"DFOP-SFO"</span>, <span class='op'>]</span>, est <span class='op'>=</span> <span class='st'>"focei"</span><span class='op'>)</span> +#> <span class='message'>dosenum=dosenum();</span></div><div class='output co'>#> <span class='message'>Needed Covariates:</span></div><div class='output co'>#> <span class='message'>[1] "f_parent_to_A1" "CMT" </span></div><div class='output co'>#> <span class='error'>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.</span></div><div class='output co'>#> <span class='message'>Timing stopped at: 7.136 0.414 7.548</span></div><div class='input'><span class='va'>f_nlmixr_dfop_sfo_focei_const</span> <span class='op'><-</span> <span class='fu'><a href='https://rdrr.io/pkg/nlmixr/man/nlmixr.html'>nlmixr</a></span><span class='op'>(</span><span class='va'>f_mmkin_const</span><span class='op'>[</span><span class='st'>"DFOP-SFO"</span>, <span class='op'>]</span>, est <span class='op'>=</span> <span class='st'>"focei"</span><span class='op'>)</span> </div><div class='output co'>#> <span class='message'><span style='color: #00BBBB;'>ℹ</span> parameter labels from comments are typically ignored in non-interactive mode</span></div><div class='output co'>#> <span class='message'><span style='color: #00BBBB;'>ℹ</span> Need to run with the source intact to parse comments</span></div><div class='output co'>#> <span class='message'>→ creating full model...</span></div><div class='output co'>#> <span class='message'>→ pruning branches (<span style='color: #262626; background-color: #DADADA;'>`if`</span>/<span style='color: #262626; background-color: #DADADA;'>`else`</span>)...</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ loading into <span style='color: #0000BB;'>symengine</span> environment...</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ creating full model...</span></div><div class='output co'>#> <span class='message'>→ pruning branches (<span style='color: #262626; background-color: #DADADA;'>`if`</span>/<span style='color: #262626; background-color: #DADADA;'>`else`</span>)...</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ loading into <span style='color: #0000BB;'>symengine</span> environment...</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ calculate jacobian</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ calculate sensitivities</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ calculate ∂(f)/∂(η)</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ calculate ∂(R²)/∂(η)</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ finding duplicate expressions in inner model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ optimizing duplicate expressions in inner model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ finding duplicate expressions in EBE model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ optimizing duplicate expressions in EBE model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ compiling inner model...</span></div><div class='output co'>#> <span class='message'> </span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ finding duplicate expressions in FD model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ optimizing duplicate expressions in FD model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ compiling EBE model...</span></div><div class='output co'>#> <span class='message'> </span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ compiling events FD model...</span></div><div class='output co'>#> <span class='message'> </span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>Model:</span></div><div class='output co'>#> <span class='message'>cmt(parent);</span> #> <span class='message'>cmt(A1);</span> #> <span class='message'>rx_expr_6~ETA[1]+THETA[1];</span> @@ -4607,10 +4607,10 @@ obtained by fitting the same model to a list of datasets using <a href='mkinfit. #> <span class='message'>f_parent=1/(1+exp(-(ETA[3]+THETA[3])));</span> #> <span class='message'>g=1/(rx_expr_20);</span> #> <span class='message'>tad=tad();</span> -#> <span class='message'>dosenum=dosenum();</span></div><div class='output co'>#> <span class='message'>Needed Covariates:</span></div><div class='output co'>#> <span class='message'>[1] "f_parent_to_A1" "CMT" </span></div><div class='output co'>#> <span class='error'>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.</span></div><div class='output co'>#> <span class='message'>Timing stopped at: 15.03 0.478 15.51</span></div><div class='input'> +#> <span class='message'>dosenum=dosenum();</span></div><div class='output co'>#> <span class='message'>Needed Covariates:</span></div><div class='output co'>#> <span class='message'>[1] "f_parent_to_A1" "CMT" </span></div><div class='output co'>#> <span class='error'>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.</span></div><div class='output co'>#> <span class='message'>Timing stopped at: 15.76 0.429 16.19</span></div><div class='input'> <span class='co'># Variance by variable is supported by 'saem' and 'focei'</span> <span class='va'>f_nlmixr_fomc_sfo_saem_obs</span> <span class='op'><-</span> <span class='fu'><a href='https://rdrr.io/pkg/nlmixr/man/nlmixr.html'>nlmixr</a></span><span class='op'>(</span><span class='va'>f_mmkin_obs</span><span class='op'>[</span><span class='st'>"FOMC-SFO"</span>, <span class='op'>]</span>, est <span class='op'>=</span> <span class='st'>"saem"</span><span class='op'>)</span> -</div><div class='output co'>#> <span class='message'><span style='color: #00BBBB;'>ℹ</span> parameter labels from comments are typically ignored in non-interactive mode</span></div><div class='output co'>#> <span class='message'><span style='color: #00BBBB;'>ℹ</span> Need to run with the source intact to parse comments</span></div><div class='output co'>#> <span class='message'> </span></div><div class='output co'>#> <span class='message'>→ generate SAEM model</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='error'>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</span></div><div class='output co'>#> <span class='message'>Timing stopped at: 1.294 0.134 1.427</span></div><div class='input'><span class='va'>f_nlmixr_fomc_sfo_focei_obs</span> <span class='op'><-</span> <span class='fu'><a href='https://rdrr.io/pkg/nlmixr/man/nlmixr.html'>nlmixr</a></span><span class='op'>(</span><span class='va'>f_mmkin_obs</span><span class='op'>[</span><span class='st'>"FOMC-SFO"</span>, <span class='op'>]</span>, est <span class='op'>=</span> <span class='st'>"focei"</span><span class='op'>)</span> +</div><div class='output co'>#> <span class='message'><span style='color: #00BBBB;'>ℹ</span> parameter labels from comments are typically ignored in non-interactive mode</span></div><div class='output co'>#> <span class='message'><span style='color: #00BBBB;'>ℹ</span> Need to run with the source intact to parse comments</span></div><div class='output co'>#> <span class='message'> </span></div><div class='output co'>#> <span class='message'>→ generate SAEM model</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='error'>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</span></div><div class='output co'>#> <span class='message'>Timing stopped at: 1.311 0.125 1.436</span></div><div class='input'><span class='va'>f_nlmixr_fomc_sfo_focei_obs</span> <span class='op'><-</span> <span class='fu'><a href='https://rdrr.io/pkg/nlmixr/man/nlmixr.html'>nlmixr</a></span><span class='op'>(</span><span class='va'>f_mmkin_obs</span><span class='op'>[</span><span class='st'>"FOMC-SFO"</span>, <span class='op'>]</span>, est <span class='op'>=</span> <span class='st'>"focei"</span><span class='op'>)</span> </div><div class='output co'>#> <span class='message'><span style='color: #00BBBB;'>ℹ</span> parameter labels from comments are typically ignored in non-interactive mode</span></div><div class='output co'>#> <span class='message'><span style='color: #00BBBB;'>ℹ</span> Need to run with the source intact to parse comments</span></div><div class='output co'>#> <span class='message'>→ creating full model...</span></div><div class='output co'>#> <span class='message'>→ pruning branches (<span style='color: #262626; background-color: #DADADA;'>`if`</span>/<span style='color: #262626; background-color: #DADADA;'>`else`</span>)...</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ loading into <span style='color: #0000BB;'>symengine</span> environment...</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ creating full model...</span></div><div class='output co'>#> <span class='message'>→ pruning branches (<span style='color: #262626; background-color: #DADADA;'>`if`</span>/<span style='color: #262626; background-color: #DADADA;'>`else`</span>)...</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ loading into <span style='color: #0000BB;'>symengine</span> environment...</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ calculate jacobian</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ calculate sensitivities</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ calculate ∂(f)/∂(η)</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ calculate ∂(R²)/∂(η)</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ finding duplicate expressions in inner model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ optimizing duplicate expressions in inner model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ finding duplicate expressions in EBE model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ optimizing duplicate expressions in EBE model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ compiling inner model...</span></div><div class='output co'>#> <span class='message'> </span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ finding duplicate expressions in FD model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ optimizing duplicate expressions in FD model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ compiling EBE model...</span></div><div class='output co'>#> <span class='message'> </span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ compiling events FD model...</span></div><div class='output co'>#> <span class='message'> </span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>Model:</span></div><div class='output co'>#> <span class='message'>cmt(parent);</span> #> <span class='message'>cmt(A1);</span> #> <span class='message'>rx_expr_6~ETA[1]+THETA[1];</span> @@ -4659,8 +4659,8 @@ obtained by fitting the same model to a list of datasets using <a href='mkinfit. #> <span class='message'>beta=exp(rx_expr_8);</span> #> <span class='message'>f_parent=1/(1+exp(-(ETA[3]+THETA[3])));</span> #> <span class='message'>tad=tad();</span> -#> <span class='message'>dosenum=dosenum();</span></div><div class='output co'>#> <span class='message'>Needed Covariates:</span></div><div class='output co'>#> <span class='message'>[1] "f_parent_to_A1" "CMT" </span></div><div class='output co'>#> <span class='error'>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.</span></div><div class='output co'>#> <span class='message'>Timing stopped at: 6.584 0.393 6.976</span></div><div class='input'><span class='va'>f_nlmixr_dfop_sfo_saem_obs</span> <span class='op'><-</span> <span class='fu'><a href='https://rdrr.io/pkg/nlmixr/man/nlmixr.html'>nlmixr</a></span><span class='op'>(</span><span class='va'>f_mmkin_obs</span><span class='op'>[</span><span class='st'>"DFOP-SFO"</span>, <span class='op'>]</span>, est <span class='op'>=</span> <span class='st'>"saem"</span><span class='op'>)</span> -</div><div class='output co'>#> <span class='message'><span style='color: #00BBBB;'>ℹ</span> parameter labels from comments are typically ignored in non-interactive mode</span></div><div class='output co'>#> <span class='message'><span style='color: #00BBBB;'>ℹ</span> Need to run with the source intact to parse comments</span></div><div class='output co'>#> <span class='message'> </span></div><div class='output co'>#> <span class='message'>→ generate SAEM model</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='error'>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</span></div><div class='output co'>#> <span class='message'>Timing stopped at: 1.302 0.142 1.443</span></div><div class='input'><span class='va'>f_nlmixr_dfop_sfo_focei_obs</span> <span class='op'><-</span> <span class='fu'><a href='https://rdrr.io/pkg/nlmixr/man/nlmixr.html'>nlmixr</a></span><span class='op'>(</span><span class='va'>f_mmkin_obs</span><span class='op'>[</span><span class='st'>"DFOP-SFO"</span>, <span class='op'>]</span>, est <span class='op'>=</span> <span class='st'>"focei"</span><span class='op'>)</span> +#> <span class='message'>dosenum=dosenum();</span></div><div class='output co'>#> <span class='message'>Needed Covariates:</span></div><div class='output co'>#> <span class='message'>[1] "f_parent_to_A1" "CMT" </span></div><div class='output co'>#> <span class='error'>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.</span></div><div class='output co'>#> <span class='message'>Timing stopped at: 6.969 0.428 7.395</span></div><div class='input'><span class='va'>f_nlmixr_dfop_sfo_saem_obs</span> <span class='op'><-</span> <span class='fu'><a href='https://rdrr.io/pkg/nlmixr/man/nlmixr.html'>nlmixr</a></span><span class='op'>(</span><span class='va'>f_mmkin_obs</span><span class='op'>[</span><span class='st'>"DFOP-SFO"</span>, <span class='op'>]</span>, est <span class='op'>=</span> <span class='st'>"saem"</span><span class='op'>)</span> +</div><div class='output co'>#> <span class='message'><span style='color: #00BBBB;'>ℹ</span> parameter labels from comments are typically ignored in non-interactive mode</span></div><div class='output co'>#> <span class='message'><span style='color: #00BBBB;'>ℹ</span> Need to run with the source intact to parse comments</span></div><div class='output co'>#> <span class='message'> </span></div><div class='output co'>#> <span class='message'>→ generate SAEM model</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='error'>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</span></div><div class='output co'>#> <span class='message'>Timing stopped at: 1.38 0.122 1.504</span></div><div class='input'><span class='va'>f_nlmixr_dfop_sfo_focei_obs</span> <span class='op'><-</span> <span class='fu'><a href='https://rdrr.io/pkg/nlmixr/man/nlmixr.html'>nlmixr</a></span><span class='op'>(</span><span class='va'>f_mmkin_obs</span><span class='op'>[</span><span class='st'>"DFOP-SFO"</span>, <span class='op'>]</span>, est <span class='op'>=</span> <span class='st'>"focei"</span><span class='op'>)</span> </div><div class='output co'>#> <span class='message'><span style='color: #00BBBB;'>ℹ</span> parameter labels from comments are typically ignored in non-interactive mode</span></div><div class='output co'>#> <span class='message'><span style='color: #00BBBB;'>ℹ</span> Need to run with the source intact to parse comments</span></div><div class='output co'>#> <span class='message'>→ creating full model...</span></div><div class='output co'>#> <span class='message'>→ pruning branches (<span style='color: #262626; background-color: #DADADA;'>`if`</span>/<span style='color: #262626; background-color: #DADADA;'>`else`</span>)...</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ loading into <span style='color: #0000BB;'>symengine</span> environment...</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ creating full model...</span></div><div class='output co'>#> <span class='message'>→ pruning branches (<span style='color: #262626; background-color: #DADADA;'>`if`</span>/<span style='color: #262626; background-color: #DADADA;'>`else`</span>)...</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ loading into <span style='color: #0000BB;'>symengine</span> environment...</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ calculate jacobian</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ calculate sensitivities</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ calculate ∂(f)/∂(η)</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ calculate ∂(R²)/∂(η)</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ finding duplicate expressions in inner model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ optimizing duplicate expressions in inner model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ finding duplicate expressions in EBE model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ optimizing duplicate expressions in EBE model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ compiling inner model...</span></div><div class='output co'>#> <span class='message'> </span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ finding duplicate expressions in FD model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ optimizing duplicate expressions in FD model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ compiling EBE model...</span></div><div class='output co'>#> <span class='message'> </span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ compiling events FD model...</span></div><div class='output co'>#> <span class='message'> </span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>Model:</span></div><div class='output co'>#> <span class='message'>cmt(parent);</span> #> <span class='message'>cmt(A1);</span> #> <span class='message'>rx_expr_6~ETA[1]+THETA[1];</span> @@ -4717,7 +4717,7 @@ obtained by fitting the same model to a list of datasets using <a href='mkinfit. #> <span class='message'>f_parent=1/(1+exp(-(ETA[3]+THETA[3])));</span> #> <span class='message'>g=1/(rx_expr_19);</span> #> <span class='message'>tad=tad();</span> -#> <span class='message'>dosenum=dosenum();</span></div><div class='output co'>#> <span class='message'>Needed Covariates:</span></div><div class='output co'>#> <span class='message'>[1] "f_parent_to_A1" "CMT" </span></div><div class='output co'>#> <span class='error'>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.</span></div><div class='output co'>#> <span class='message'>Timing stopped at: 14.58 0.482 15.06</span></div><div class='input'> +#> <span class='message'>dosenum=dosenum();</span></div><div class='output co'>#> <span class='message'>Needed Covariates:</span></div><div class='output co'>#> <span class='message'>[1] "f_parent_to_A1" "CMT" </span></div><div class='output co'>#> <span class='error'>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.</span></div><div class='output co'>#> <span class='message'>Timing stopped at: 15.48 0.348 15.82</span></div><div class='input'> <span class='co'># Identical two-component error for all variables is only possible with</span> <span class='co'># est = 'focei' in nlmixr</span> <span class='va'>f_nlmixr_fomc_sfo_focei_tc</span> <span class='op'><-</span> <span class='fu'><a href='https://rdrr.io/pkg/nlmixr/man/nlmixr.html'>nlmixr</a></span><span class='op'>(</span><span class='va'>f_mmkin_tc</span><span class='op'>[</span><span class='st'>"FOMC-SFO"</span>, <span class='op'>]</span>, est <span class='op'>=</span> <span class='st'>"focei"</span><span class='op'>)</span> @@ -4771,7 +4771,7 @@ obtained by fitting the same model to a list of datasets using <a href='mkinfit. #> <span class='message'>beta=exp(rx_expr_8);</span> #> <span class='message'>f_parent=1/(1+exp(-(ETA[3]+THETA[3])));</span> #> <span class='message'>tad=tad();</span> -#> <span class='message'>dosenum=dosenum();</span></div><div class='output co'>#> <span class='message'>Needed Covariates:</span></div><div class='output co'>#> <span class='message'>[1] "f_parent_to_A1" "CMT" </span></div><div class='output co'>#> <span class='error'>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.</span></div><div class='output co'>#> <span class='message'>Timing stopped at: 8.484 0.401 8.883</span></div><div class='input'><span class='va'>f_nlmixr_dfop_sfo_focei_tc</span> <span class='op'><-</span> <span class='fu'><a href='https://rdrr.io/pkg/nlmixr/man/nlmixr.html'>nlmixr</a></span><span class='op'>(</span><span class='va'>f_mmkin_tc</span><span class='op'>[</span><span class='st'>"DFOP-SFO"</span>, <span class='op'>]</span>, est <span class='op'>=</span> <span class='st'>"focei"</span><span class='op'>)</span> +#> <span class='message'>dosenum=dosenum();</span></div><div class='output co'>#> <span class='message'>Needed Covariates:</span></div><div class='output co'>#> <span class='message'>[1] "f_parent_to_A1" "CMT" </span></div><div class='output co'>#> <span class='error'>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.</span></div><div class='output co'>#> <span class='message'>Timing stopped at: 8.84 0.482 9.319</span></div><div class='input'><span class='va'>f_nlmixr_dfop_sfo_focei_tc</span> <span class='op'><-</span> <span class='fu'><a href='https://rdrr.io/pkg/nlmixr/man/nlmixr.html'>nlmixr</a></span><span class='op'>(</span><span class='va'>f_mmkin_tc</span><span class='op'>[</span><span class='st'>"DFOP-SFO"</span>, <span class='op'>]</span>, est <span class='op'>=</span> <span class='st'>"focei"</span><span class='op'>)</span> </div><div class='output co'>#> <span class='message'><span style='color: #00BBBB;'>ℹ</span> parameter labels from comments are typically ignored in non-interactive mode</span></div><div class='output co'>#> <span class='message'><span style='color: #00BBBB;'>ℹ</span> Need to run with the source intact to parse comments</span></div><div class='output co'>#> <span class='message'>→ creating full model...</span></div><div class='output co'>#> <span class='message'>→ pruning branches (<span style='color: #262626; background-color: #DADADA;'>`if`</span>/<span style='color: #262626; background-color: #DADADA;'>`else`</span>)...</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ loading into <span style='color: #0000BB;'>symengine</span> environment...</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ creating full model...</span></div><div class='output co'>#> <span class='message'>→ pruning branches (<span style='color: #262626; background-color: #DADADA;'>`if`</span>/<span style='color: #262626; background-color: #DADADA;'>`else`</span>)...</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ loading into <span style='color: #0000BB;'>symengine</span> environment...</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ calculate jacobian</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ calculate sensitivities</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ calculate ∂(f)/∂(η)</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ calculate ∂(R²)/∂(η)</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ finding duplicate expressions in inner model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ optimizing duplicate expressions in inner model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ finding duplicate expressions in EBE model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ optimizing duplicate expressions in EBE model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ compiling inner model...</span></div><div class='output co'>#> <span class='message'> </span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ finding duplicate expressions in FD model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ optimizing duplicate expressions in FD model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ compiling EBE model...</span></div><div class='output co'>#> <span class='message'> </span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ compiling events FD model...</span></div><div class='output co'>#> <span class='message'> </span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>Model:</span></div><div class='output co'>#> <span class='message'>cmt(parent);</span> #> <span class='message'>cmt(A1);</span> #> <span class='message'>rx_expr_6~ETA[1]+THETA[1];</span> @@ -4830,12 +4830,12 @@ obtained by fitting the same model to a list of datasets using <a href='mkinfit. #> <span class='message'>f_parent=1/(1+exp(-(ETA[3]+THETA[3])));</span> #> <span class='message'>g=1/(rx_expr_21);</span> #> <span class='message'>tad=tad();</span> -#> <span class='message'>dosenum=dosenum();</span></div><div class='output co'>#> <span class='message'>Needed Covariates:</span></div><div class='output co'>#> <span class='message'>[1] "f_parent_to_A1" "CMT" </span></div><div class='output co'>#> <span class='error'>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.</span></div><div class='output co'>#> <span class='message'>Timing stopped at: 18.44 0.438 18.87</span></div><div class='input'> +#> <span class='message'>dosenum=dosenum();</span></div><div class='output co'>#> <span class='message'>Needed Covariates:</span></div><div class='output co'>#> <span class='message'>[1] "f_parent_to_A1" "CMT" </span></div><div class='output co'>#> <span class='error'>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.</span></div><div class='output co'>#> <span class='message'>Timing stopped at: 19.56 0.433 19.99</span></div><div class='input'> <span class='co'># Two-component error by variable is possible with both estimation methods</span> <span class='co'># Variance by variable is supported by 'saem' and 'focei'</span> <span class='va'>f_nlmixr_fomc_sfo_saem_obs_tc</span> <span class='op'><-</span> <span class='fu'><a href='https://rdrr.io/pkg/nlmixr/man/nlmixr.html'>nlmixr</a></span><span class='op'>(</span><span class='va'>f_mmkin_tc</span><span class='op'>[</span><span class='st'>"FOMC-SFO"</span>, <span class='op'>]</span>, est <span class='op'>=</span> <span class='st'>"saem"</span>, error_model <span class='op'>=</span> <span class='st'>"obs_tc"</span><span class='op'>)</span> -</div><div class='output co'>#> <span class='message'><span style='color: #00BBBB;'>ℹ</span> parameter labels from comments are typically ignored in non-interactive mode</span></div><div class='output co'>#> <span class='message'><span style='color: #00BBBB;'>ℹ</span> Need to run with the source intact to parse comments</span></div><div class='output co'>#> <span class='message'> </span></div><div class='output co'>#> <span class='error'>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</span></div><div class='output co'>#> <span class='message'>Timing stopped at: 0.784 0.028 0.812</span></div><div class='input'><span class='va'>f_nlmixr_fomc_sfo_focei_obs_tc</span> <span class='op'><-</span> <span class='fu'><a href='https://rdrr.io/pkg/nlmixr/man/nlmixr.html'>nlmixr</a></span><span class='op'>(</span><span class='va'>f_mmkin_tc</span><span class='op'>[</span><span class='st'>"FOMC-SFO"</span>, <span class='op'>]</span>, est <span class='op'>=</span> <span class='st'>"focei"</span>, +</div><div class='output co'>#> <span class='message'><span style='color: #00BBBB;'>ℹ</span> parameter labels from comments are typically ignored in non-interactive mode</span></div><div class='output co'>#> <span class='message'><span style='color: #00BBBB;'>ℹ</span> Need to run with the source intact to parse comments</span></div><div class='output co'>#> <span class='message'> </span></div><div class='output co'>#> <span class='error'>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</span></div><div class='output co'>#> <span class='message'>Timing stopped at: 0.817 0.016 0.834</span></div><div class='input'><span class='va'>f_nlmixr_fomc_sfo_focei_obs_tc</span> <span class='op'><-</span> <span class='fu'><a href='https://rdrr.io/pkg/nlmixr/man/nlmixr.html'>nlmixr</a></span><span class='op'>(</span><span class='va'>f_mmkin_tc</span><span class='op'>[</span><span class='st'>"FOMC-SFO"</span>, <span class='op'>]</span>, est <span class='op'>=</span> <span class='st'>"focei"</span>, error_model <span class='op'>=</span> <span class='st'>"obs_tc"</span><span class='op'>)</span> </div><div class='output co'>#> <span class='message'><span style='color: #00BBBB;'>ℹ</span> parameter labels from comments are typically ignored in non-interactive mode</span></div><div class='output co'>#> <span class='message'><span style='color: #00BBBB;'>ℹ</span> Need to run with the source intact to parse comments</span></div><div class='output co'>#> <span class='message'>→ creating full model...</span></div><div class='output co'>#> <span class='message'>→ pruning branches (<span style='color: #262626; background-color: #DADADA;'>`if`</span>/<span style='color: #262626; background-color: #DADADA;'>`else`</span>)...</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ loading into <span style='color: #0000BB;'>symengine</span> environment...</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ creating full model...</span></div><div class='output co'>#> <span class='message'>→ pruning branches (<span style='color: #262626; background-color: #DADADA;'>`if`</span>/<span style='color: #262626; background-color: #DADADA;'>`else`</span>)...</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ loading into <span style='color: #0000BB;'>symengine</span> environment...</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ calculate jacobian</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ calculate sensitivities</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ calculate ∂(f)/∂(η)</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ calculate ∂(R²)/∂(η)</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ finding duplicate expressions in inner model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ optimizing duplicate expressions in inner model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ finding duplicate expressions in EBE model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ optimizing duplicate expressions in EBE model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ compiling inner model...</span></div><div class='output co'>#> <span class='message'> </span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ finding duplicate expressions in FD model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ optimizing duplicate expressions in FD model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ compiling EBE model...</span></div><div class='output co'>#> <span class='message'> </span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ compiling events FD model...</span></div><div class='output co'>#> <span class='message'> </span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>Model:</span></div><div class='output co'>#> <span class='message'>cmt(parent);</span> #> <span class='message'>cmt(A1);</span> @@ -4887,9 +4887,9 @@ obtained by fitting the same model to a list of datasets using <a href='mkinfit. #> <span class='message'>beta=exp(rx_expr_8);</span> #> <span class='message'>f_parent=1/(1+exp(-(ETA[3]+THETA[3])));</span> #> <span class='message'>tad=tad();</span> -#> <span class='message'>dosenum=dosenum();</span></div><div class='output co'>#> <span class='message'>Needed Covariates:</span></div><div class='output co'>#> <span class='message'>[1] "f_parent_to_A1" "CMT" </span></div><div class='output co'>#> <span class='error'>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.</span></div><div class='output co'>#> <span class='message'>Timing stopped at: 8.157 0.51 8.664</span></div><div class='input'><span class='va'>f_nlmixr_dfop_sfo_saem_obs_tc</span> <span class='op'><-</span> <span class='fu'><a href='https://rdrr.io/pkg/nlmixr/man/nlmixr.html'>nlmixr</a></span><span class='op'>(</span><span class='va'>f_mmkin_tc</span><span class='op'>[</span><span class='st'>"DFOP-SFO"</span>, <span class='op'>]</span>, est <span class='op'>=</span> <span class='st'>"saem"</span>, +#> <span class='message'>dosenum=dosenum();</span></div><div class='output co'>#> <span class='message'>Needed Covariates:</span></div><div class='output co'>#> <span class='message'>[1] "f_parent_to_A1" "CMT" </span></div><div class='output co'>#> <span class='error'>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.</span></div><div class='output co'>#> <span class='message'>Timing stopped at: 8.572 0.437 9.008</span></div><div class='input'><span class='va'>f_nlmixr_dfop_sfo_saem_obs_tc</span> <span class='op'><-</span> <span class='fu'><a href='https://rdrr.io/pkg/nlmixr/man/nlmixr.html'>nlmixr</a></span><span class='op'>(</span><span class='va'>f_mmkin_tc</span><span class='op'>[</span><span class='st'>"DFOP-SFO"</span>, <span class='op'>]</span>, est <span class='op'>=</span> <span class='st'>"saem"</span>, error_model <span class='op'>=</span> <span class='st'>"obs_tc"</span><span class='op'>)</span> -</div><div class='output co'>#> <span class='message'><span style='color: #00BBBB;'>ℹ</span> parameter labels from comments are typically ignored in non-interactive mode</span></div><div class='output co'>#> <span class='message'><span style='color: #00BBBB;'>ℹ</span> Need to run with the source intact to parse comments</span></div><div class='output co'>#> <span class='message'> </span></div><div class='output co'>#> <span class='error'>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</span></div><div class='output co'>#> <span class='message'>Timing stopped at: 0.81 0.045 0.854</span></div><div class='input'><span class='va'>f_nlmixr_dfop_sfo_focei_obs_tc</span> <span class='op'><-</span> <span class='fu'><a href='https://rdrr.io/pkg/nlmixr/man/nlmixr.html'>nlmixr</a></span><span class='op'>(</span><span class='va'>f_mmkin_tc</span><span class='op'>[</span><span class='st'>"DFOP-SFO"</span>, <span class='op'>]</span>, est <span class='op'>=</span> <span class='st'>"focei"</span>, +</div><div class='output co'>#> <span class='message'><span style='color: #00BBBB;'>ℹ</span> parameter labels from comments are typically ignored in non-interactive mode</span></div><div class='output co'>#> <span class='message'><span style='color: #00BBBB;'>ℹ</span> Need to run with the source intact to parse comments</span></div><div class='output co'>#> <span class='message'> </span></div><div class='output co'>#> <span class='error'>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</span></div><div class='output co'>#> <span class='message'>Timing stopped at: 0.866 0.032 0.897</span></div><div class='input'><span class='va'>f_nlmixr_dfop_sfo_focei_obs_tc</span> <span class='op'><-</span> <span class='fu'><a href='https://rdrr.io/pkg/nlmixr/man/nlmixr.html'>nlmixr</a></span><span class='op'>(</span><span class='va'>f_mmkin_tc</span><span class='op'>[</span><span class='st'>"DFOP-SFO"</span>, <span class='op'>]</span>, est <span class='op'>=</span> <span class='st'>"focei"</span>, error_model <span class='op'>=</span> <span class='st'>"obs_tc"</span><span class='op'>)</span> </div><div class='output co'>#> <span class='message'><span style='color: #00BBBB;'>ℹ</span> parameter labels from comments are typically ignored in non-interactive mode</span></div><div class='output co'>#> <span class='message'><span style='color: #00BBBB;'>ℹ</span> Need to run with the source intact to parse comments</span></div><div class='output co'>#> <span class='message'>→ creating full model...</span></div><div class='output co'>#> <span class='message'>→ pruning branches (<span style='color: #262626; background-color: #DADADA;'>`if`</span>/<span style='color: #262626; background-color: #DADADA;'>`else`</span>)...</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ loading into <span style='color: #0000BB;'>symengine</span> environment...</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ creating full model...</span></div><div class='output co'>#> <span class='message'>→ pruning branches (<span style='color: #262626; background-color: #DADADA;'>`if`</span>/<span style='color: #262626; background-color: #DADADA;'>`else`</span>)...</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ loading into <span style='color: #0000BB;'>symengine</span> environment...</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ calculate jacobian</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ calculate sensitivities</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ calculate ∂(f)/∂(η)</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ calculate ∂(R²)/∂(η)</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ finding duplicate expressions in inner model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ optimizing duplicate expressions in inner model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ finding duplicate expressions in EBE model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ optimizing duplicate expressions in EBE model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ compiling inner model...</span></div><div class='output co'>#> <span class='message'> </span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ finding duplicate expressions in FD model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ optimizing duplicate expressions in FD model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ compiling EBE model...</span></div><div class='output co'>#> <span class='message'> </span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ compiling events FD model...</span></div><div class='output co'>#> <span class='message'> </span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>Model:</span></div><div class='output co'>#> <span class='message'>cmt(parent);</span> #> <span class='message'>cmt(A1);</span> @@ -4949,7 +4949,7 @@ obtained by fitting the same model to a list of datasets using <a href='mkinfit. #> <span class='message'>f_parent=1/(1+exp(-(ETA[3]+THETA[3])));</span> #> <span class='message'>g=1/(rx_expr_19);</span> #> <span class='message'>tad=tad();</span> -#> <span class='message'>dosenum=dosenum();</span></div><div class='output co'>#> <span class='message'>Needed Covariates:</span></div><div class='output co'>#> <span class='message'>[1] "f_parent_to_A1" "CMT" </span></div><div class='output co'>#> <span class='error'>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.</span></div><div class='output co'>#> <span class='message'>Timing stopped at: 17.34 0.397 17.73</span></div><div class='input'> +#> <span class='message'>dosenum=dosenum();</span></div><div class='output co'>#> <span class='message'>Needed Covariates:</span></div><div class='output co'>#> <span class='message'>[1] "f_parent_to_A1" "CMT" </span></div><div class='output co'>#> <span class='error'>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.</span></div><div class='output co'>#> <span class='message'>Timing stopped at: 19.34 0.349 19.69</span></div><div class='input'> <span class='fu'><a href='https://rdrr.io/r/stats/AIC.html'>AIC</a></span><span class='op'>(</span> <span class='va'>f_nlmixr_sfo_sfo_focei_const</span><span class='op'>$</span><span class='va'>nm</span>, <span class='va'>f_nlmixr_fomc_sfo_focei_const</span><span class='op'>$</span><span class='va'>nm</span>, diff --git a/docs/dev/reference/plot.mixed.mmkin.html b/docs/dev/reference/plot.mixed.mmkin.html index 7f3faa90..8962ce1c 100644 --- a/docs/dev/reference/plot.mixed.mmkin.html +++ b/docs/dev/reference/plot.mixed.mmkin.html @@ -72,7 +72,7 @@ </button> <span class="navbar-brand"> <a class="navbar-link" href="../index.html">mkin</a> - <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.1.0</span> + <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.0.5</span> </span> </div> @@ -296,10 +296,10 @@ corresponding model prediction lines for the different datasets.</p></td> </div><div class='img'><img src='plot.mixed.mmkin-2.png' alt='' width='700' height='433' /></div><div class='input'> <span class='va'>f_saem</span> <span class='op'><-</span> <span class='fu'><a href='saem.html'>saem</a></span><span class='op'>(</span><span class='va'>f</span>, transformations <span class='op'>=</span> <span class='st'>"saemix"</span><span class='op'>)</span> </div><div class='output co'>#> Running main SAEM algorithm -#> [1] "Tue Jul 27 16:30:50 2021" +#> [1] "Thu Jul 29 12:13:54 2021" #> .... #> Minimisation finished -#> [1] "Tue Jul 27 16:30:58 2021"</div><div class='input'><span class='fu'><a href='https://rdrr.io/r/graphics/plot.default.html'>plot</a></span><span class='op'>(</span><span class='va'>f_saem</span><span class='op'>)</span> +#> [1] "Thu Jul 29 12:14:02 2021"</div><div class='input'><span class='fu'><a href='https://rdrr.io/r/graphics/plot.default.html'>plot</a></span><span class='op'>(</span><span class='va'>f_saem</span><span class='op'>)</span> </div><div class='img'><img src='plot.mixed.mmkin-3.png' alt='' width='700' height='433' /></div><div class='input'> <span class='va'>f_obs</span> <span class='op'><-</span> <span class='fu'><a href='mmkin.html'>mmkin</a></span><span class='op'>(</span><span class='fu'><a href='https://rdrr.io/r/base/list.html'>list</a></span><span class='op'>(</span><span class='st'>"DFOP-SFO"</span> <span class='op'>=</span> <span class='va'>dfop_sfo</span><span class='op'>)</span>, <span class='va'>ds</span>, quiet <span class='op'>=</span> <span class='cn'>TRUE</span>, error_model <span class='op'>=</span> <span class='st'>"obs"</span><span class='op'>)</span> <span class='va'>f_nlmix</span> <span class='op'><-</span> <span class='fu'>nlmix</span><span class='op'>(</span><span class='va'>f_obs</span><span class='op'>)</span> diff --git a/docs/dev/reference/reexports.html b/docs/dev/reference/reexports.html index ac4fa4d9..f5ace044 100644 --- a/docs/dev/reference/reexports.html +++ b/docs/dev/reference/reexports.html @@ -81,7 +81,7 @@ below to see their documentation. </button> <span class="navbar-brand"> <a class="navbar-link" href="../index.html">mkin</a> - <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.1.0</span> + <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.0.5</span> </span> </div> diff --git a/docs/dev/reference/saem.html b/docs/dev/reference/saem.html index 15271c8a..0334e0e1 100644 --- a/docs/dev/reference/saem.html +++ b/docs/dev/reference/saem.html @@ -74,7 +74,7 @@ Expectation Maximisation algorithm (SAEM)." /> </button> <span class="navbar-brand"> <a class="navbar-link" href="../index.html">mkin</a> - <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.1.0</span> + <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.0.5</span> </span> </div> @@ -288,27 +288,27 @@ using <a href='mmkin.html'>mmkin</a>.</p> state.ini <span class='op'>=</span> <span class='fu'><a href='https://rdrr.io/r/base/c.html'>c</a></span><span class='op'>(</span>parent <span class='op'>=</span> <span class='fl'>100</span><span class='op'>)</span>, fixed_initials <span class='op'>=</span> <span class='st'>"parent"</span>, quiet <span class='op'>=</span> <span class='cn'>TRUE</span><span class='op'>)</span> <span class='va'>f_saem_p0_fixed</span> <span class='op'><-</span> <span class='fu'>saem</span><span class='op'>(</span><span class='va'>f_mmkin_parent_p0_fixed</span><span class='op'>)</span> </div><div class='output co'>#> Running main SAEM algorithm -#> [1] "Tue Jul 27 16:31:02 2021" +#> [1] "Thu Jul 29 12:14:07 2021" #> .... #> Minimisation finished -#> [1] "Tue Jul 27 16:31:04 2021"</div><div class='input'> +#> [1] "Thu Jul 29 12:14:08 2021"</div><div class='input'> <span class='va'>f_mmkin_parent</span> <span class='op'><-</span> <span class='fu'><a href='mmkin.html'>mmkin</a></span><span class='op'>(</span><span class='fu'><a href='https://rdrr.io/r/base/c.html'>c</a></span><span class='op'>(</span><span class='st'>"SFO"</span>, <span class='st'>"FOMC"</span>, <span class='st'>"DFOP"</span><span class='op'>)</span>, <span class='va'>ds</span>, quiet <span class='op'>=</span> <span class='cn'>TRUE</span><span class='op'>)</span> <span class='va'>f_saem_sfo</span> <span class='op'><-</span> <span class='fu'>saem</span><span class='op'>(</span><span class='va'>f_mmkin_parent</span><span class='op'>[</span><span class='st'>"SFO"</span>, <span class='op'>]</span><span class='op'>)</span> </div><div class='output co'>#> Running main SAEM algorithm -#> [1] "Tue Jul 27 16:31:06 2021" +#> [1] "Thu Jul 29 12:14:11 2021" #> .... #> Minimisation finished -#> [1] "Tue Jul 27 16:31:07 2021"</div><div class='input'><span class='va'>f_saem_fomc</span> <span class='op'><-</span> <span class='fu'>saem</span><span class='op'>(</span><span class='va'>f_mmkin_parent</span><span class='op'>[</span><span class='st'>"FOMC"</span>, <span class='op'>]</span><span class='op'>)</span> +#> [1] "Thu Jul 29 12:14:12 2021"</div><div class='input'><span class='va'>f_saem_fomc</span> <span class='op'><-</span> <span class='fu'>saem</span><span class='op'>(</span><span class='va'>f_mmkin_parent</span><span class='op'>[</span><span class='st'>"FOMC"</span>, <span class='op'>]</span><span class='op'>)</span> </div><div class='output co'>#> Running main SAEM algorithm -#> [1] "Tue Jul 27 16:31:07 2021" +#> [1] "Thu Jul 29 12:14:12 2021" #> .... #> Minimisation finished -#> [1] "Tue Jul 27 16:31:09 2021"</div><div class='input'><span class='va'>f_saem_dfop</span> <span class='op'><-</span> <span class='fu'>saem</span><span class='op'>(</span><span class='va'>f_mmkin_parent</span><span class='op'>[</span><span class='st'>"DFOP"</span>, <span class='op'>]</span><span class='op'>)</span> +#> [1] "Thu Jul 29 12:14:14 2021"</div><div class='input'><span class='va'>f_saem_dfop</span> <span class='op'><-</span> <span class='fu'>saem</span><span class='op'>(</span><span class='va'>f_mmkin_parent</span><span class='op'>[</span><span class='st'>"DFOP"</span>, <span class='op'>]</span><span class='op'>)</span> </div><div class='output co'>#> Running main SAEM algorithm -#> [1] "Tue Jul 27 16:31:10 2021" +#> [1] "Thu Jul 29 12:14:15 2021" #> .... #> Minimisation finished -#> [1] "Tue Jul 27 16:31:12 2021"</div><div class='input'> +#> [1] "Thu Jul 29 12:14:18 2021"</div><div class='input'> <span class='co'># The returned saem.mmkin object contains an SaemixObject, therefore we can use</span> <span class='co'># functions from saemix</span> <span class='kw'><a href='https://rdrr.io/r/base/library.html'>library</a></span><span class='op'>(</span><span class='va'>saemix</span><span class='op'>)</span> @@ -357,10 +357,10 @@ using <a href='mmkin.html'>mmkin</a>.</p> <span class='va'>f_mmkin_parent_tc</span> <span class='op'><-</span> <span class='fu'><a href='https://rdrr.io/r/stats/update.html'>update</a></span><span class='op'>(</span><span class='va'>f_mmkin_parent</span>, error_model <span class='op'>=</span> <span class='st'>"tc"</span><span class='op'>)</span> <span class='va'>f_saem_fomc_tc</span> <span class='op'><-</span> <span class='fu'>saem</span><span class='op'>(</span><span class='va'>f_mmkin_parent_tc</span><span class='op'>[</span><span class='st'>"FOMC"</span>, <span class='op'>]</span><span class='op'>)</span> </div><div class='output co'>#> Running main SAEM algorithm -#> [1] "Tue Jul 27 16:31:16 2021" +#> [1] "Thu Jul 29 12:14:21 2021" #> .... #> Minimisation finished -#> [1] "Tue Jul 27 16:31:20 2021"</div><div class='input'><span class='fu'><a href='https://rdrr.io/pkg/saemix/man/compare.saemix.html'>compare.saemix</a></span><span class='op'>(</span><span class='va'>f_saem_fomc</span><span class='op'>$</span><span class='va'>so</span>, <span class='va'>f_saem_fomc_tc</span><span class='op'>$</span><span class='va'>so</span><span class='op'>)</span> +#> [1] "Thu Jul 29 12:14:27 2021"</div><div class='input'><span class='fu'><a href='https://rdrr.io/pkg/saemix/man/compare.saemix.html'>compare.saemix</a></span><span class='op'>(</span><span class='va'>f_saem_fomc</span><span class='op'>$</span><span class='va'>so</span>, <span class='va'>f_saem_fomc_tc</span><span class='op'>$</span><span class='va'>so</span><span class='op'>)</span> </div><div class='output co'>#> <span class='message'>Likelihoods calculated by importance sampling</span></div><div class='output co'>#> AIC BIC #> 1 467.7096 464.9757 #> 2 469.6831 466.5586</div><div class='input'> @@ -381,15 +381,15 @@ using <a href='mmkin.html'>mmkin</a>.</p> <span class='co'># four minutes</span> <span class='va'>f_saem_sfo_sfo</span> <span class='op'><-</span> <span class='fu'>saem</span><span class='op'>(</span><span class='va'>f_mmkin</span><span class='op'>[</span><span class='st'>"SFO-SFO"</span>, <span class='op'>]</span><span class='op'>)</span> </div><div class='output co'>#> Running main SAEM algorithm -#> [1] "Tue Jul 27 16:31:24 2021" +#> [1] "Thu Jul 29 12:14:31 2021" #> .... #> Minimisation finished -#> [1] "Tue Jul 27 16:31:29 2021"</div><div class='input'><span class='va'>f_saem_dfop_sfo</span> <span class='op'><-</span> <span class='fu'>saem</span><span class='op'>(</span><span class='va'>f_mmkin</span><span class='op'>[</span><span class='st'>"DFOP-SFO"</span>, <span class='op'>]</span><span class='op'>)</span> +#> [1] "Thu Jul 29 12:14:36 2021"</div><div class='input'><span class='va'>f_saem_dfop_sfo</span> <span class='op'><-</span> <span class='fu'>saem</span><span class='op'>(</span><span class='va'>f_mmkin</span><span class='op'>[</span><span class='st'>"DFOP-SFO"</span>, <span class='op'>]</span><span class='op'>)</span> </div><div class='output co'>#> Running main SAEM algorithm -#> [1] "Tue Jul 27 16:31:30 2021" +#> [1] "Thu Jul 29 12:14:36 2021" #> .... #> Minimisation finished -#> [1] "Tue Jul 27 16:31:38 2021"</div><div class='input'><span class='co'># We can use print, plot and summary methods to check the results</span> +#> [1] "Thu Jul 29 12:14:46 2021"</div><div class='input'><span class='co'># We can use print, plot and summary methods to check the results</span> <span class='fu'><a href='https://rdrr.io/r/base/print.html'>print</a></span><span class='op'>(</span><span class='va'>f_saem_dfop_sfo</span><span class='op'>)</span> </div><div class='output co'>#> Kinetic nonlinear mixed-effects model fit by SAEM #> Structural model: @@ -430,10 +430,10 @@ using <a href='mmkin.html'>mmkin</a>.</p> #> SD.g_qlogis 0.44816 -1.25437 2.1507</div><div class='input'><span class='fu'><a href='https://rdrr.io/pkg/saemix/man/plot-SaemixObject-method.html'>plot</a></span><span class='op'>(</span><span class='va'>f_saem_dfop_sfo</span><span class='op'>)</span> </div><div class='img'><img src='saem-5.png' alt='' width='700' height='433' /></div><div class='input'><span class='fu'><a href='https://rdrr.io/pkg/saemix/man/summary-methods.html'>summary</a></span><span class='op'>(</span><span class='va'>f_saem_dfop_sfo</span>, data <span class='op'>=</span> <span class='cn'>TRUE</span><span class='op'>)</span> </div><div class='output co'>#> saemix version used for fitting: 3.1.9000 -#> mkin version used for pre-fitting: 1.1.0 +#> mkin version used for pre-fitting: 1.0.5 #> R version used for fitting: 4.1.0 -#> Date of fit: Tue Jul 27 16:31:39 2021 -#> Date of summary: Tue Jul 27 16:31:39 2021 +#> Date of fit: Thu Jul 29 12:14:46 2021 +#> Date of summary: Thu Jul 29 12:14:46 2021 #> #> Equations: #> d_parent/dt = - ((k1 * g * exp(-k1 * time) + k2 * (1 - g) * exp(-k2 * @@ -448,7 +448,7 @@ using <a href='mmkin.html'>mmkin</a>.</p> #> #> Model predictions using solution type analytical #> -#> Fitted in 9.479 s using 300, 100 iterations +#> Fitted in 9.987 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 373ce75f..f0131701 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 </button> <span class="navbar-brand"> <a class="navbar-link" href="../index.html">mkin</a> - <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.1.0</span> + <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.0.5</span> </span> </div> @@ -258,12 +258,12 @@ nlmixr authors for the parts inherited from nlmixr.</p> quiet <span class='op'>=</span> <span class='cn'>TRUE</span>, error_model <span class='op'>=</span> <span class='st'>"tc"</span>, cores <span class='op'>=</span> <span class='fl'>5</span><span class='op'>)</span> <span class='va'>f_saemix_dfop_sfo</span> <span class='op'><-</span> <span class='fu'>mkin</span><span class='fu'>::</span><span class='fu'><a href='saem.html'>saem</a></span><span class='op'>(</span><span class='va'>f_mmkin_dfop_sfo</span><span class='op'>)</span> </div><div class='output co'>#> Running main SAEM algorithm -#> [1] "Tue Jul 27 16:31:43 2021" +#> [1] "Thu Jul 29 12:14:50 2021" #> .... #> Minimisation finished -#> [1] "Tue Jul 27 16:31:55 2021"</div><div class='input'><span class='va'>f_nlme_dfop_sfo</span> <span class='op'><-</span> <span class='fu'>mkin</span><span class='fu'>::</span><span class='fu'><a href='https://rdrr.io/pkg/nlme/man/nlme.html'>nlme</a></span><span class='op'>(</span><span class='va'>f_mmkin_dfop_sfo</span><span class='op'>)</span> +#> [1] "Thu Jul 29 12:15:03 2021"</div><div class='input'><span class='va'>f_nlme_dfop_sfo</span> <span class='op'><-</span> <span class='fu'>mkin</span><span class='fu'>::</span><span class='fu'><a href='https://rdrr.io/pkg/nlme/man/nlme.html'>nlme</a></span><span class='op'>(</span><span class='va'>f_mmkin_dfop_sfo</span><span class='op'>)</span> </div><div class='output co'>#> <span class='warning'>Warning: Iteration 4, LME step: nlminb() did not converge (code = 1). PORT message: false convergence (8)</span></div><div class='output co'>#> <span class='warning'>Warning: Iteration 6, LME step: nlminb() did not converge (code = 1). PORT message: false convergence (8)</span></div><div class='input'><span class='va'>f_nlmixr_dfop_sfo_saem</span> <span class='op'><-</span> <span class='fu'><a href='https://rdrr.io/pkg/nlmixr/man/nlmixr.html'>nlmixr</a></span><span class='op'>(</span><span class='va'>f_mmkin_dfop_sfo</span>, est <span class='op'>=</span> <span class='st'>"saem"</span><span class='op'>)</span> -</div><div class='output co'>#> <span class='message'>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)</span></div><div class='output co'>#> <span class='message'><span style='color: #00BBBB;'>ℹ</span> parameter labels from comments are typically ignored in non-interactive mode</span></div><div class='output co'>#> <span class='message'><span style='color: #00BBBB;'>ℹ</span> Need to run with the source intact to parse comments</span></div><div class='output co'>#> <span class='message'> </span></div><div class='output co'>#> <span class='message'>→ generate SAEM model</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='error'>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</span></div><div class='output co'>#> <span class='message'>Timing stopped at: 1.281 0.142 1.422</span></div><div class='input'><span class='co'># The following takes a very long time but gives</span> +</div><div class='output co'>#> <span class='message'>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)</span></div><div class='output co'>#> <span class='message'><span style='color: #00BBBB;'>ℹ</span> parameter labels from comments are typically ignored in non-interactive mode</span></div><div class='output co'>#> <span class='message'><span style='color: #00BBBB;'>ℹ</span> Need to run with the source intact to parse comments</span></div><div class='output co'>#> <span class='message'> </span></div><div class='output co'>#> <span class='message'>→ generate SAEM model</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='error'>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</span></div><div class='output co'>#> <span class='message'>Timing stopped at: 1.464 0.114 1.576</span></div><div class='input'><span class='co'># The following takes a very long time but gives</span> <span class='va'>f_nlmixr_dfop_sfo_focei</span> <span class='op'><-</span> <span class='fu'><a href='https://rdrr.io/pkg/nlmixr/man/nlmixr.html'>nlmixr</a></span><span class='op'>(</span><span class='va'>f_mmkin_dfop_sfo</span>, est <span class='op'>=</span> <span class='st'>"focei"</span><span class='op'>)</span> </div><div class='output co'>#> <span class='message'><span style='color: #00BBBB;'>ℹ</span> parameter labels from comments are typically ignored in non-interactive mode</span></div><div class='output co'>#> <span class='message'><span style='color: #00BBBB;'>ℹ</span> Need to run with the source intact to parse comments</span></div><div class='output co'>#> <span class='message'>→ creating full model...</span></div><div class='output co'>#> <span class='message'>→ pruning branches (<span style='color: #262626; background-color: #DADADA;'>`if`</span>/<span style='color: #262626; background-color: #DADADA;'>`else`</span>)...</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ loading into <span style='color: #0000BB;'>symengine</span> environment...</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ creating full model...</span></div><div class='output co'>#> <span class='message'>→ pruning branches (<span style='color: #262626; background-color: #DADADA;'>`if`</span>/<span style='color: #262626; background-color: #DADADA;'>`else`</span>)...</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ loading into <span style='color: #0000BB;'>symengine</span> environment...</span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ calculate jacobian</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ calculate sensitivities</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ calculate ∂(f)/∂(η)</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ calculate ∂(R²)/∂(η)</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ finding duplicate expressions in inner model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ optimizing duplicate expressions in inner model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ finding duplicate expressions in EBE model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ optimizing duplicate expressions in EBE model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ compiling inner model...</span></div><div class='output co'>#> <span class='message'> </span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ finding duplicate expressions in FD model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ optimizing duplicate expressions in FD model...</span></div><div class='output co'>#> </div><div class='output co'>#> <span class='message'>→ compiling EBE model...</span></div><div class='output co'>#> <span class='message'> </span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>→ compiling events FD model...</span></div><div class='output co'>#> <span class='message'> </span></div><div class='output co'>#> <span class='message'><span style='color: #00BB00;'>✔</span> done</span></div><div class='output co'>#> <span class='message'>Model:</span></div><div class='output co'>#> <span class='message'>cmt(parent);</span> #> <span class='message'>cmt(m1);</span> @@ -323,7 +323,7 @@ nlmixr authors for the parts inherited from nlmixr.</p> #> <span class='message'>f_parent=1/(1+exp(-(ETA[3]+THETA[3])));</span> #> <span class='message'>g=1/(rx_expr_21);</span> #> <span class='message'>tad=tad();</span> -#> <span class='message'>dosenum=dosenum();</span></div><div class='output co'>#> <span class='message'>Needed Covariates:</span></div><div class='output co'>#> <span class='message'>[1] "f_parent_to_m1" "CMT" </span></div><div class='output co'>#> <span class='error'>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.</span></div><div class='output co'>#> <span class='message'>Timing stopped at: 19.01 0.403 19.42</span></div><div class='input'><span class='fu'><a href='https://rdrr.io/r/stats/AIC.html'>AIC</a></span><span class='op'>(</span><span class='va'>f_nlmixr_dfop_sfo_saem</span><span class='op'>$</span><span class='va'>nm</span>, <span class='va'>f_nlmixr_dfop_sfo_focei</span><span class='op'>$</span><span class='va'>nm</span><span class='op'>)</span> +#> <span class='message'>dosenum=dosenum();</span></div><div class='output co'>#> <span class='message'>Needed Covariates:</span></div><div class='output co'>#> <span class='message'>[1] "f_parent_to_m1" "CMT" </span></div><div class='output co'>#> <span class='error'>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.</span></div><div class='output co'>#> <span class='message'>Timing stopped at: 19.62 0.431 20.06</span></div><div class='input'><span class='fu'><a href='https://rdrr.io/r/stats/AIC.html'>AIC</a></span><span class='op'>(</span><span class='va'>f_nlmixr_dfop_sfo_saem</span><span class='op'>$</span><span class='va'>nm</span>, <span class='va'>f_nlmixr_dfop_sfo_focei</span><span class='op'>$</span><span class='va'>nm</span><span class='op'>)</span> </div><div class='output co'>#> <span class='error'>Error in AIC(f_nlmixr_dfop_sfo_saem$nm, f_nlmixr_dfop_sfo_focei$nm): object 'f_nlmixr_dfop_sfo_saem' not found</span></div><div class='input'><span class='fu'><a href='https://rdrr.io/pkg/saemix/man/summary-methods.html'>summary</a></span><span class='op'>(</span><span class='va'>f_nlmixr_dfop_sfo_sfo</span>, data <span class='op'>=</span> <span class='cn'>TRUE</span><span class='op'>)</span> </div><div class='output co'>#> <span class='error'>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</span></div><div class='input'><span class='co'># }</span> diff --git a/docs/dev/reference/summary.saem.mmkin.html b/docs/dev/reference/summary.saem.mmkin.html index fdfdaf4b..aeb08d12 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.</p> quiet <span class='op'>=</span> <span class='cn'>TRUE</span>, error_model <span class='op'>=</span> <span class='st'>"tc"</span>, cores <span class='op'>=</span> <span class='fl'>5</span><span class='op'>)</span> <span class='va'>f_saem_dfop_sfo</span> <span class='op'><-</span> <span class='fu'><a href='saem.html'>saem</a></span><span class='op'>(</span><span class='va'>f_mmkin_dfop_sfo</span><span class='op'>)</span> </div><div class='output co'>#> Running main SAEM algorithm -#> [1] "Fri Jun 11 10:58:28 2021" +#> [1] "Thu Jul 29 12:15:32 2021" #> .... #> Minimisation finished -#> [1] "Fri Jun 11 10:58:40 2021"</div><div class='input'><span class='fu'><a href='https://rdrr.io/pkg/saemix/man/summary-methods.html'>summary</a></span><span class='op'>(</span><span class='va'>f_saem_dfop_sfo</span>, data <span class='op'>=</span> <span class='cn'>TRUE</span><span class='op'>)</span> +#> [1] "Thu Jul 29 12:15:44 2021"</div><div class='input'><span class='fu'><a href='https://rdrr.io/pkg/saemix/man/summary-methods.html'>summary</a></span><span class='op'>(</span><span class='va'>f_saem_dfop_sfo</span>, data <span class='op'>=</span> <span class='cn'>TRUE</span><span class='op'>)</span> </div><div class='output co'>#> 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: Fri Jun 11 10:58:41 2021 -#> Date of summary: Fri Jun 11 10:58:41 2021 +#> Date of fit: Thu Jul 29 12:15:45 2021 +#> Date of summary: Thu Jul 29 12:15:45 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.</p> #> #> Model predictions using solution type analytical #> -#> Fitted in 12.75 s using 300, 100 iterations +#> Fitted in 13.372 s using 300, 100 iterations #> #> Variance model: Two-component variance function #> diff --git a/docs/dev/reference/tffm0.html b/docs/dev/reference/tffm0.html index 67f26b85..d993e8ff 100644 --- a/docs/dev/reference/tffm0.html +++ b/docs/dev/reference/tffm0.html @@ -81,7 +81,7 @@ from RxODE." /> </button> <span class="navbar-brand"> <a class="navbar-link" href="../index.html">mkin</a> - <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.1.0</span> + <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.0.5</span> </span> </div> |
