diff options
Diffstat (limited to 'docs/dev')
38 files changed, 375 insertions, 352 deletions
diff --git a/docs/dev/404.html b/docs/dev/404.html index 98c0b1e0..38898979 100644 --- a/docs/dev/404.html +++ b/docs/dev/404.html @@ -71,7 +71,7 @@ </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.0.5</span> + <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.1.0</span> </span> </div> diff --git a/docs/dev/articles/index.html b/docs/dev/articles/index.html index 99ce950b..c0338df8 100644 --- a/docs/dev/articles/index.html +++ b/docs/dev/articles/index.html @@ -71,7 +71,7 @@ </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.0.5</span> + <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.1.0</span> </span> </div> diff --git a/docs/dev/articles/web_only/dimethenamid_2018.html b/docs/dev/articles/web_only/dimethenamid_2018.html index 9a6d8388..b35d8210 100644 --- a/docs/dev/articles/web_only/dimethenamid_2018.html +++ b/docs/dev/articles/web_only/dimethenamid_2018.html @@ -32,7 +32,7 @@ </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.0.5</span> + <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.1.0</span> </span> </div> @@ -95,13 +95,13 @@ - </header><script src="dimethenamid_2018_files/header-attrs-2.9/header-attrs.js"></script><script src="dimethenamid_2018_files/accessible-code-block-0.0.1/empty-anchor.js"></script><div class="row"> + </header><script src="dimethenamid_2018_files/header-attrs-2.11/header-attrs.js"></script><script src="dimethenamid_2018_files/accessible-code-block-0.0.1/empty-anchor.js"></script><div class="row"> <div class="col-md-9 contents"> <div class="page-header toc-ignore"> <h1 data-toc-skip>Example evaluations of the dimethenamid data from 2018</h1> <h4 class="author">Johannes Ranke</h4> - <h4 class="date">Last change 4 August 2021, built on 04 Aug 2021</h4> + <h4 class="date">Last change 16 September 2021, built on 16 Sep 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> @@ -110,31 +110,28 @@ -<p><a href="http://www.jrwb.de">Wissenschaftlicher Berater, Kronacher Str. 12, 79639 Grenzach-Wyhlen, Germany</a><br><a href="http://chem.uft.uni-bremen.de/ranke">Privatdozent at the University of Bremen</a></p> +<p><a href="http://www.jrwb.de">Wissenschaftlicher Berater, Kronacher Str. 12, 79639 Grenzach-Wyhlen, Germany</a></p> <div id="introduction" class="section level1"> <h1 class="hasAnchor"> <a href="#introduction" class="anchor"></a>Introduction</h1> -<p>During the preparation of the journal article on nonlinear mixed-effects models in degradation kinetics (submitted) and the analysis of the dimethenamid degradation data analysed therein, a need for a more detailed analysis using not only nlme and saemix, but also nlmixr for fitting the mixed-effects models was identified.</p> +<p>During the preparation of the journal article on nonlinear mixed-effects models in degradation kinetics <span class="citation">(Ranke et al. 2021)</span> and the analysis of the dimethenamid degradation data analysed therein, a need for a more detailed analysis using not only nlme and saemix, but also nlmixr for fitting the mixed-effects models was identified.</p> <p>This vignette is an attempt to satisfy this need.</p> </div> <div id="data" class="section level1"> <h1 class="hasAnchor"> <a href="#data" class="anchor"></a>Data</h1> -<p>Residue data forming the basis for the endpoints derived in the conclusion on the peer review of the pesticide risk assessment of dimethenamid-P published by the European Food Safety Authority (EFSA) in 2018 <span class="citation">(EFSA 2018)</span> were transcribed from the risk assessment report <span class="citation">(Rapporteur Member State Germany, Co-Rapporteur Member State Bulgaria 2018)</span> which can be downloaded from the <a href="https://open.efsa.europa.eu/study-inventory/EFSA-Q-2014-00716">EFSA register of questions</a>.</p> +<p>Residue data forming the basis for the endpoints derived in the conclusion on the peer review of the pesticide risk assessment of dimethenamid-P published by the European Food Safety Authority (EFSA) in 2018 <span class="citation">(EFSA 2018)</span> were transcribed from the risk assessment report <span class="citation">(Rapporteur Member State Germany, Co-Rapporteur Member State Bulgaria 2018)</span> which can be downloaded from the Open EFSA repository <a href="https://open.efsa.europa.eu">https://open.efsa.europa.eu/study-inventory/EFSA-Q-2014-00716</a>.</p> <p>The data are <a href="https://pkgdown.jrwb.de/mkin/reference/dimethenamid_2018.html">available in the mkin package</a>. The following code (hidden by default, please use the button to the right to show it) treats the data available for the racemic mixture dimethenamid (DMTA) and its enantiomer dimethenamid-P (DMTAP) in the same way, as no difference between their degradation behaviour was identified in the EU risk assessment. The observation times of each dataset are multiplied with the corresponding normalisation factor also available in the dataset, in order to make it possible to describe all datasets with a single set of parameters.</p> <p>Also, datasets observed in the same soil are merged, resulting in dimethenamid (DMTA) data from six soils.</p> <div class="sourceCode" id="cb1"><pre class="downlit sourceCode r"> <code class="sourceCode R"><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> -<span class="va">dmta_ds</span> <span class="op"><-</span> <span class="fu"><a href="https://rdrr.io/r/base/lapply.html">lapply</a></span><span class="op">(</span><span class="fl">1</span><span class="op">:</span><span class="fl">8</span>, <span class="kw">function</span><span class="op">(</span><span class="va">i</span><span class="op">)</span> <span class="op">{</span> +<span class="va">dmta_ds</span> <span class="op"><-</span> <span class="fu"><a href="https://rdrr.io/r/base/lapply.html">lapply</a></span><span class="op">(</span><span class="fl">1</span><span class="op">:</span><span class="fl">7</span>, <span class="kw">function</span><span class="op">(</span><span class="va">i</span><span class="op">)</span> <span class="op">{</span> <span class="va">ds_i</span> <span class="op"><-</span> <span class="va">dimethenamid_2018</span><span class="op">$</span><span class="va">ds</span><span class="op">[[</span><span class="va">i</span><span class="op">]</span><span class="op">]</span><span class="op">$</span><span class="va">data</span> <span class="va">ds_i</span><span class="op">[</span><span class="va">ds_i</span><span class="op">$</span><span class="va">name</span> <span class="op">==</span> <span class="st">"DMTAP"</span>, <span class="st">"name"</span><span class="op">]</span> <span class="op"><-</span> <span class="st">"DMTA"</span> <span class="va">ds_i</span><span class="op">$</span><span class="va">time</span> <span class="op"><-</span> <span class="va">ds_i</span><span class="op">$</span><span class="va">time</span> <span class="op">*</span> <span class="va">dimethenamid_2018</span><span class="op">$</span><span class="va">f_time_norm</span><span class="op">[</span><span class="va">i</span><span class="op">]</span> <span class="va">ds_i</span> <span class="op">}</span><span class="op">)</span> <span class="fu"><a href="https://rdrr.io/r/base/names.html">names</a></span><span class="op">(</span><span class="va">dmta_ds</span><span class="op">)</span> <span class="op"><-</span> <span class="fu"><a href="https://rdrr.io/r/base/lapply.html">sapply</a></span><span class="op">(</span><span class="va">dimethenamid_2018</span><span class="op">$</span><span class="va">ds</span>, <span class="kw">function</span><span class="op">(</span><span class="va">ds</span><span class="op">)</span> <span class="va">ds</span><span class="op">$</span><span class="va">title</span><span class="op">)</span> -<span class="va">dmta_ds</span><span class="op">[[</span><span class="st">"Borstel"</span><span class="op">]</span><span class="op">]</span> <span class="op"><-</span> <span class="fu"><a href="https://rdrr.io/r/base/cbind.html">rbind</a></span><span class="op">(</span><span class="va">dmta_ds</span><span class="op">[[</span><span class="st">"Borstel 1"</span><span class="op">]</span><span class="op">]</span>, <span class="va">dmta_ds</span><span class="op">[[</span><span class="st">"Borstel 2"</span><span class="op">]</span><span class="op">]</span><span class="op">)</span> -<span class="va">dmta_ds</span><span class="op">[[</span><span class="st">"Borstel 1"</span><span class="op">]</span><span class="op">]</span> <span class="op"><-</span> <span class="cn">NULL</span> -<span class="va">dmta_ds</span><span class="op">[[</span><span class="st">"Borstel 2"</span><span class="op">]</span><span class="op">]</span> <span class="op"><-</span> <span class="cn">NULL</span> <span class="va">dmta_ds</span><span class="op">[[</span><span class="st">"Elliot"</span><span class="op">]</span><span class="op">]</span> <span class="op"><-</span> <span class="fu"><a href="https://rdrr.io/r/base/cbind.html">rbind</a></span><span class="op">(</span><span class="va">dmta_ds</span><span class="op">[[</span><span class="st">"Elliot 1"</span><span class="op">]</span><span class="op">]</span>, <span class="va">dmta_ds</span><span class="op">[[</span><span class="st">"Elliot 2"</span><span class="op">]</span><span class="op">]</span><span class="op">)</span> <span class="va">dmta_ds</span><span class="op">[[</span><span class="st">"Elliot 1"</span><span class="op">]</span><span class="op">]</span> <span class="op"><-</span> <span class="cn">NULL</span> <span class="va">dmta_ds</span><span class="op">[[</span><span class="st">"Elliot 2"</span><span class="op">]</span><span class="op">]</span> <span class="op"><-</span> <span class="cn">NULL</span></code></pre></div> @@ -154,20 +151,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/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> +<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> <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/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> +<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> <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/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> +<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> <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/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> +<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> <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"> @@ -177,175 +174,184 @@ <div id="nlme" class="section level3"> <h3 class="hasAnchor"> <a href="#nlme" class="anchor"></a>nlme</h3> -<p>The nlme package was the first R extension providing facilities to fit nonlinear mixed-effects models. We use would like to do model selection from all four combinations of degradation models and error models based on the AIC. However, fitting the DFOP model with constant variance and using default control parameters results in an error, signalling that the maximum number of 50 iterations was reached, potentially indicating overparameterisation. However, the algorithm converges when the two-component error model is used in combination with the DFOP model. This can be explained by the fact that the smaller residues observed at later sampling times get more weight when using the two-component error model which will counteract the tendency of the algorithm to try parameter combinations unsuitable for fitting these data.</p> +<p>The nlme package was the first R extension providing facilities to fit nonlinear mixed-effects models. We would like to do model selection from all four combinations of degradation models and error models based on the AIC. However, fitting the DFOP model with constant variance and using default control parameters results in an error, signalling that the maximum number of 50 iterations was reached, potentially indicating overparameterisation. However, the algorithm converges when the two-component error model is used in combination with the DFOP model. This can be explained by the fact that the smaller residues observed at later sampling times get more weight when using the two-component error model which will counteract the tendency of the algorithm to try parameter combinations unsuitable for fitting these data.</p> <div class="sourceCode" id="cb7"><pre class="downlit sourceCode r"> <code class="sourceCode R"><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://svn.r-project.org/R-packages/trunk/nlme/">nlme</a></span><span class="op">)</span> <span class="va">f_parent_nlme_sfo_const</span> <span class="op"><-</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_parent_mkin_const</span><span class="op">[</span><span class="st">"SFO"</span>, <span class="op">]</span><span class="op">)</span> -<span class="co">#f_parent_nlme_dfop_const <- nlme(f_parent_mkin_const["DFOP", ])</span> -<span class="co"># maxIter = 50 reached</span> +<span class="co"># f_parent_nlme_dfop_const <- nlme(f_parent_mkin_const["DFOP", ])</span> <span class="va">f_parent_nlme_sfo_tc</span> <span class="op"><-</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_parent_mkin_tc</span><span class="op">[</span><span class="st">"SFO"</span>, <span class="op">]</span><span class="op">)</span> <span class="va">f_parent_nlme_dfop_tc</span> <span class="op"><-</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_parent_mkin_tc</span><span class="op">[</span><span class="st">"DFOP"</span>, <span class="op">]</span><span class="op">)</span></code></pre></div> -<p>Note that overparameterisation is also indicated by warnings obtained when fitting SFO or DFOP with the two-component error model (‘false convergence’ in the ‘LME step’ in some iterations). In addition to these fits, attempts were also made to include correlations between random effects by using the log Cholesky parameterisation of the matrix specifying them. The code used for these attempts can be made visible below.</p> +<p>Note that a certain degree of overparameterisation is also indicated by a warning obtained when fitting DFOP with the two-component error model (‘false convergence’ in the ‘LME step’ in iteration 3). However, as this warning does not occur in later iterations, and specifically not in the last of the 6 iterations, we can ignore this warning.</p> +<p>The model comparison function of the nlme package can directly be applied to these fits showing a much lower AIC for the DFOP model fitted with the two-component error model. Also, the likelihood ratio test indicates that this difference is significant. as the p-value is below 0.0001.</p> <div class="sourceCode" id="cb8"><pre class="downlit sourceCode r"> -<code class="sourceCode R"><span class="va">f_parent_nlme_sfo_const_logchol</span> <span class="op"><-</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_parent_mkin_const</span><span class="op">[</span><span class="st">"SFO"</span>, <span class="op">]</span>, - random <span class="op">=</span> <span class="fu"><a href="https://rdrr.io/pkg/nlme/man/pdLogChol.html">pdLogChol</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="va">DMTA_0</span> <span class="op">~</span> <span class="fl">1</span>, <span class="va">log_k_DMTA</span> <span class="op">~</span> <span class="fl">1</span><span class="op">)</span><span class="op">)</span><span class="op">)</span> -<span class="fu"><a href="https://rdrr.io/r/stats/anova.html">anova</a></span><span class="op">(</span><span class="va">f_parent_nlme_sfo_const</span>, <span class="va">f_parent_nlme_sfo_const_logchol</span><span class="op">)</span> <span class="co"># not better</span> -<span class="co">#f_parent_nlme_dfop_tc_logchol <- update(f_parent_nlme_dfop_tc,</span> -<span class="co"># random = pdLogChol(list(DMTA_0 ~ 1, log_k1 ~ 1, log_k2 ~ 1, g_qlogis ~ 1)))</span> -<span class="co"># using log Cholesky parameterisation for random effects (nlme default) does</span> -<span class="co"># not converge here and gives lots of warnings about the LME step not converging</span></code></pre></div> -<p>The model comparison function of the nlme package can directly be applied to these fits showing a similar goodness-of-fit of the SFO model, but a much lower AIC for the DFOP model fitted with the two-component error model. Also, the likelihood ratio test indicates that this difference is significant. as the p-value is below 0.0001.</p> -<div class="sourceCode" id="cb9"><pre class="downlit sourceCode r"> <code class="sourceCode R"><span class="fu"><a href="https://rdrr.io/r/stats/anova.html">anova</a></span><span class="op">(</span> <span class="va">f_parent_nlme_sfo_const</span>, <span class="va">f_parent_nlme_sfo_tc</span>, <span class="va">f_parent_nlme_dfop_tc</span> <span class="op">)</span></code></pre></div> <pre><code> Model df AIC BIC logLik Test L.Ratio p-value -f_parent_nlme_sfo_const 1 5 818.63 834.00 -404.31 -f_parent_nlme_sfo_tc 2 6 820.61 839.06 -404.31 1 vs 2 0.014 0.9049 -f_parent_nlme_dfop_tc 3 10 687.84 718.59 -333.92 2 vs 3 140.771 <.0001</code></pre> +f_parent_nlme_sfo_const 1 5 796.60 811.82 -393.30 +f_parent_nlme_sfo_tc 2 6 798.60 816.86 -393.30 1 vs 2 0.00 0.998 +f_parent_nlme_dfop_tc 3 10 671.91 702.34 -325.96 2 vs 3 134.69 <.0001</code></pre> +<p>In addition to these fits, attempts were also made to include correlations between random effects by using the log Cholesky parameterisation of the matrix specifying them. The code used for these attempts can be made visible below.</p> +<div class="sourceCode" id="cb10"><pre class="downlit sourceCode r"> +<code class="sourceCode R"><span class="va">f_parent_nlme_sfo_const_logchol</span> <span class="op"><-</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_parent_mkin_const</span><span class="op">[</span><span class="st">"SFO"</span>, <span class="op">]</span>, + random <span class="op">=</span> <span class="fu">nlme</span><span class="fu">::</span><span class="fu"><a href="https://rdrr.io/pkg/nlme/man/pdLogChol.html">pdLogChol</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="va">DMTA_0</span> <span class="op">~</span> <span class="fl">1</span>, <span class="va">log_k_DMTA</span> <span class="op">~</span> <span class="fl">1</span><span class="op">)</span><span class="op">)</span><span class="op">)</span> +<span class="fu"><a href="https://rdrr.io/r/stats/anova.html">anova</a></span><span class="op">(</span><span class="va">f_parent_nlme_sfo_const</span>, <span class="va">f_parent_nlme_sfo_const_logchol</span><span class="op">)</span> +<span class="va">f_parent_nlme_sfo_tc_logchol</span> <span class="op"><-</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_parent_mkin_tc</span><span class="op">[</span><span class="st">"SFO"</span>, <span class="op">]</span>, + random <span class="op">=</span> <span class="fu">nlme</span><span class="fu">::</span><span class="fu"><a href="https://rdrr.io/pkg/nlme/man/pdLogChol.html">pdLogChol</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="va">DMTA_0</span> <span class="op">~</span> <span class="fl">1</span>, <span class="va">log_k_DMTA</span> <span class="op">~</span> <span class="fl">1</span><span class="op">)</span><span class="op">)</span><span class="op">)</span> +<span class="fu"><a href="https://rdrr.io/r/stats/anova.html">anova</a></span><span class="op">(</span><span class="va">f_parent_nlme_sfo_tc</span>, <span class="va">f_parent_nlme_sfo_tc_logchol</span><span class="op">)</span> +<span class="va">f_parent_nlme_dfop_tc_logchol</span> <span class="op"><-</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_parent_mkin_const</span><span class="op">[</span><span class="st">"DFOP"</span>, <span class="op">]</span>, + random <span class="op">=</span> <span class="fu">nlme</span><span class="fu">::</span><span class="fu"><a href="https://rdrr.io/pkg/nlme/man/pdLogChol.html">pdLogChol</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="va">DMTA_0</span> <span class="op">~</span> <span class="fl">1</span>, <span class="va">log_k1</span> <span class="op">~</span> <span class="fl">1</span>, <span class="va">log_k2</span> <span class="op">~</span> <span class="fl">1</span>, <span class="va">g_qlogis</span> <span class="op">~</span> <span class="fl">1</span><span class="op">)</span><span class="op">)</span><span class="op">)</span> +<span class="fu"><a href="https://rdrr.io/r/stats/anova.html">anova</a></span><span class="op">(</span><span class="va">f_parent_nlme_dfop_tc</span>, <span class="va">f_parent_nlme_dfop_tc_logchol</span><span class="op">)</span></code></pre></div> +<p>While the SFO variants converge fast, the additional parameters introduced by this lead to convergence warnings for the DFOP model. The model comparison clearly show that adding correlations between random effects does not improve the fits.</p> <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/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> +<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> <p><img src="dimethenamid_2018_files/figure-html/plot_parent_nlme-1.png" width="700"></p> </div> <div id="saemix" class="section level3"> <h3 class="hasAnchor"> <a href="#saemix" class="anchor"></a>saemix</h3> -<p>The saemix package provided the first Open Source implementation of the Stochastic Approximation to the Expectation Maximisation (SAEM) algorithm. SAEM fits of degradation models can be performed using an interface to the saemix package available in current development versions of the mkin package.</p> -<p>The corresponding SAEM fits of the four combinations of degradation and error models are fitted below. As there is no convergence criterion implemented in the saemix package, the convergence plots need to be manually checked for every fit.</p> -<p>The convergence plot for the SFO model using constant variance is shown below.</p> +<p>The saemix package provided the first Open Source implementation of the Stochastic Approximation to the Expectation Maximisation (SAEM) algorithm. SAEM fits of degradation models can be conveniently performed using an interface to the saemix package available in current development versions of the mkin package.</p> +<p>The corresponding SAEM fits of the four combinations of degradation and error models are fitted below. As there is no convergence criterion implemented in the saemix package, the convergence plots need to be manually checked for every fit. As we will compare the SAEM implementation of saemix to the results obtained using the nlmixr package later, we define control settings that work well for all the parent data fits shown in this vignette.</p> <div class="sourceCode" id="cb12"><pre class="downlit sourceCode r"> <code class="sourceCode R"><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> -<span class="va">f_parent_saemix_sfo_const</span> <span class="op"><-</span> <span class="fu">mkin</span><span class="fu">::</span><span class="fu"><a href="../../reference/saem.html">saem</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>, quiet <span class="op">=</span> <span class="cn">TRUE</span>, - transformations <span class="op">=</span> <span class="st">"saemix"</span><span class="op">)</span> +<span class="va">saemix_control</span> <span class="op"><-</span> <span class="fu"><a href="https://rdrr.io/pkg/saemix/man/saemixControl.html">saemixControl</a></span><span class="op">(</span>nbiter.saemix <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">800</span>, <span class="fl">300</span><span class="op">)</span>, nb.chains <span class="op">=</span> <span class="fl">15</span>, + print <span class="op">=</span> <span class="cn">FALSE</span>, save <span class="op">=</span> <span class="cn">FALSE</span>, save.graphs <span class="op">=</span> <span class="cn">FALSE</span>, displayProgress <span class="op">=</span> <span class="cn">FALSE</span><span class="op">)</span></code></pre></div> +<p>The convergence plot for the SFO model using constant variance is shown below.</p> +<div class="sourceCode" id="cb13"><pre class="downlit sourceCode r"> +<code class="sourceCode R"><span class="va">f_parent_saemix_sfo_const</span> <span class="op"><-</span> <span class="fu">mkin</span><span class="fu">::</span><span class="fu"><a href="../../reference/saem.html">saem</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>, quiet <span class="op">=</span> <span class="cn">TRUE</span>, + control <span class="op">=</span> <span class="va">saemix_control</span>, transformations <span class="op">=</span> <span class="st">"saemix"</span><span class="op">)</span> <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_saemix_sfo_const</span><span class="op">$</span><span class="va">so</span>, plot.type <span class="op">=</span> <span class="st">"convergence"</span><span class="op">)</span></code></pre></div> <p><img src="dimethenamid_2018_files/figure-html/f_parent_saemix_sfo_const-1.png" width="700"></p> <p>Obviously the default number of iterations is sufficient to reach convergence. This can also be said for the SFO fit using the two-component error model.</p> -<div class="sourceCode" id="cb13"><pre class="downlit sourceCode r"> +<div class="sourceCode" id="cb14"><pre class="downlit sourceCode r"> <code class="sourceCode R"><span class="va">f_parent_saemix_sfo_tc</span> <span class="op"><-</span> <span class="fu">mkin</span><span class="fu">::</span><span class="fu"><a href="../../reference/saem.html">saem</a></span><span class="op">(</span><span class="va">f_parent_mkin_tc</span><span class="op">[</span><span class="st">"SFO"</span>, <span class="op">]</span>, quiet <span class="op">=</span> <span class="cn">TRUE</span>, - transformations <span class="op">=</span> <span class="st">"saemix"</span><span class="op">)</span> + control <span class="op">=</span> <span class="va">saemix_control</span>, transformations <span class="op">=</span> <span class="st">"saemix"</span><span class="op">)</span> <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_saemix_sfo_tc</span><span class="op">$</span><span class="va">so</span>, plot.type <span class="op">=</span> <span class="st">"convergence"</span><span class="op">)</span></code></pre></div> <p><img src="dimethenamid_2018_files/figure-html/f_parent_saemix_sfo_tc-1.png" width="700"></p> <p>When fitting the DFOP model with constant variance, parameter convergence is not as unambiguous (see the failure of nlme with the default number of iterations above). Therefore, the number of iterations in the first phase of the algorithm was increased, leading to visually satisfying convergence.</p> -<div class="sourceCode" id="cb14"><pre class="downlit sourceCode r"> +<div class="sourceCode" id="cb15"><pre class="downlit sourceCode r"> <code class="sourceCode R"><span class="va">f_parent_saemix_dfop_const</span> <span class="op"><-</span> <span class="fu">mkin</span><span class="fu">::</span><span class="fu"><a href="../../reference/saem.html">saem</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>, quiet <span class="op">=</span> <span class="cn">TRUE</span>, - control <span class="op">=</span> <span class="fu"><a href="https://rdrr.io/pkg/saemix/man/saemixControl.html">saemixControl</a></span><span class="op">(</span>nbiter.saemix <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">800</span>, <span class="fl">200</span><span class="op">)</span>, print <span class="op">=</span> <span class="cn">FALSE</span>, - save <span class="op">=</span> <span class="cn">FALSE</span>, save.graphs <span class="op">=</span> <span class="cn">FALSE</span>, displayProgress <span class="op">=</span> <span class="cn">FALSE</span><span class="op">)</span>, - transformations <span class="op">=</span> <span class="st">"saemix"</span><span class="op">)</span> + control <span class="op">=</span> <span class="va">saemix_control</span>, transformations <span class="op">=</span> <span class="st">"saemix"</span><span class="op">)</span> <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_saemix_dfop_const</span><span class="op">$</span><span class="va">so</span>, plot.type <span class="op">=</span> <span class="st">"convergence"</span><span class="op">)</span></code></pre></div> <p><img src="dimethenamid_2018_files/figure-html/f_parent_saemix_dfop_const-1.png" width="700"></p> -<p>The same applies to the case where the DFOP model is fitted with the two-component error model. Convergence of the variance of k2 is enhanced by using the two-component error, it remains more or less stable already after 200 iterations of the first phase.</p> -<div class="sourceCode" id="cb15"><pre class="downlit sourceCode r"> -<code class="sourceCode R"><span class="va">f_parent_saemix_dfop_tc_moreiter</span> <span class="op"><-</span> <span class="fu">mkin</span><span class="fu">::</span><span class="fu"><a href="../../reference/saem.html">saem</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>, quiet <span class="op">=</span> <span class="cn">TRUE</span>, - control <span class="op">=</span> <span class="fu"><a href="https://rdrr.io/pkg/saemix/man/saemixControl.html">saemixControl</a></span><span class="op">(</span>nbiter.saemix <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">800</span>, <span class="fl">200</span><span class="op">)</span>, print <span class="op">=</span> <span class="cn">FALSE</span>, - save <span class="op">=</span> <span class="cn">FALSE</span>, save.graphs <span class="op">=</span> <span class="cn">FALSE</span>, displayProgress <span class="op">=</span> <span class="cn">FALSE</span><span class="op">)</span>, - transformations <span class="op">=</span> <span class="st">"saemix"</span><span class="op">)</span> -<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_saemix_dfop_tc_moreiter</span><span class="op">$</span><span class="va">so</span>, plot.type <span class="op">=</span> <span class="st">"convergence"</span><span class="op">)</span></code></pre></div> -<p><img src="dimethenamid_2018_files/figure-html/f_parent_saemix_dfop_tc_moreiter-1.png" width="700"></p> -<p>The four combinations can be compared using the model comparison function from the saemix package:</p> +<p>The same applies in the case where the DFOP model is fitted with the two-component error model. Convergence of the variance of k2 is enhanced by using the two-component error, it remains more or less stable already after 200 iterations of the first phase.</p> <div class="sourceCode" id="cb16"><pre class="downlit sourceCode r"> -<code class="sourceCode R"><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_parent_saemix_sfo_const</span><span class="op">$</span><span class="va">so</span>, <span class="va">f_parent_saemix_sfo_tc</span><span class="op">$</span><span class="va">so</span>, - <span class="va">f_parent_saemix_dfop_const</span><span class="op">$</span><span class="va">so</span>, <span class="va">f_parent_saemix_dfop_tc_moreiter</span><span class="op">$</span><span class="va">so</span><span class="op">)</span></code></pre></div> +<code class="sourceCode R"><span class="va">f_parent_saemix_dfop_tc</span> <span class="op"><-</span> <span class="fu">mkin</span><span class="fu">::</span><span class="fu"><a href="../../reference/saem.html">saem</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>, quiet <span class="op">=</span> <span class="cn">TRUE</span>, + control <span class="op">=</span> <span class="va">saemix_control</span>, transformations <span class="op">=</span> <span class="st">"saemix"</span><span class="op">)</span> +<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_saemix_dfop_tc</span><span class="op">$</span><span class="va">so</span>, plot.type <span class="op">=</span> <span class="st">"convergence"</span><span class="op">)</span></code></pre></div> +<p><img src="dimethenamid_2018_files/figure-html/f_parent_saemix_dfop_tc-1.png" width="700"> The four combinations and including the variations of the DFOP/tc combination can be compared using the model comparison function from the saemix package:</p> +<div class="sourceCode" id="cb17"><pre class="downlit sourceCode r"> +<code class="sourceCode R"><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_parent_saemix_sfo_const</span><span class="op">$</span><span class="va">so</span>, + <span class="va">f_parent_saemix_sfo_tc</span><span class="op">$</span><span class="va">so</span>, + <span class="va">f_parent_saemix_dfop_const</span><span class="op">$</span><span class="va">so</span>, + <span class="va">f_parent_saemix_dfop_tc</span><span class="op">$</span><span class="va">so</span><span class="op">)</span></code></pre></div> <pre><code>Likelihoods calculated by importance sampling</code></pre> <pre><code> AIC BIC -1 818.37 817.33 -2 820.38 819.14 -3 725.91 724.04 -4 683.64 681.55</code></pre> -<p>As in the case of nlme fits, the DFOP model fitted with two-component error (number 4) gives the lowest AIC. The numeric values are reasonably close to the ones obtained using nlme, considering that the algorithms for fitting the model and for the likelihood calculation are quite different.</p> +1 796.37 795.33 +2 798.37 797.13 +3 713.16 711.28 +4 666.10 664.01</code></pre> +<p>As in the case of nlme fits, the DFOP model fitted with two-component error (number 4) gives the lowest AIC. Using more iterations and/or more chains does not have a large influence on the final AIC (not shown).</p> <p>In order to check the influence of the likelihood calculation algorithms implemented in saemix, the likelihood from Gaussian quadrature is added to the best fit, and the AIC values obtained from the three methods are compared.</p> -<div class="sourceCode" id="cb19"><pre class="downlit sourceCode r"> -<code class="sourceCode R"><span class="va">f_parent_saemix_dfop_tc_moreiter</span><span class="op">$</span><span class="va">so</span> <span class="op"><-</span> - <span class="fu"><a href="https://rdrr.io/pkg/saemix/man/llgq.saemix.html">llgq.saemix</a></span><span class="op">(</span><span class="va">f_parent_saemix_dfop_tc_moreiter</span><span class="op">$</span><span class="va">so</span><span class="op">)</span> -<span class="fu"><a href="https://rdrr.io/r/stats/AIC.html">AIC</a></span><span class="op">(</span><span class="va">f_parent_saemix_dfop_tc_moreiter</span><span class="op">$</span><span class="va">so</span><span class="op">)</span></code></pre></div> -<pre><code>[1] 683.64</code></pre> -<div class="sourceCode" id="cb21"><pre class="downlit sourceCode r"> -<code class="sourceCode R"><span class="fu"><a href="https://rdrr.io/r/stats/AIC.html">AIC</a></span><span class="op">(</span><span class="va">f_parent_saemix_dfop_tc_moreiter</span><span class="op">$</span><span class="va">so</span>, method <span class="op">=</span> <span class="st">"gq"</span><span class="op">)</span></code></pre></div> -<pre><code>[1] 683.7</code></pre> -<div class="sourceCode" id="cb23"><pre class="downlit sourceCode r"> -<code class="sourceCode R"><span class="fu"><a href="https://rdrr.io/r/stats/AIC.html">AIC</a></span><span class="op">(</span><span class="va">f_parent_saemix_dfop_tc_moreiter</span><span class="op">$</span><span class="va">so</span>, method <span class="op">=</span> <span class="st">"lin"</span><span class="op">)</span></code></pre></div> -<pre><code>[1] 683.17</code></pre> -<p>The AIC values based on importance sampling and Gaussian quadrature are quite similar. Using linearisation is less accurate, but still gives a similar value.</p> +<div class="sourceCode" id="cb20"><pre class="downlit sourceCode r"> +<code class="sourceCode R"><span class="va">f_parent_saemix_dfop_tc</span><span class="op">$</span><span class="va">so</span> <span class="op"><-</span> + <span class="fu"><a href="https://rdrr.io/pkg/saemix/man/llgq.saemix.html">llgq.saemix</a></span><span class="op">(</span><span class="va">f_parent_saemix_dfop_tc</span><span class="op">$</span><span class="va">so</span><span class="op">)</span> +<span class="fu"><a href="https://rdrr.io/r/stats/AIC.html">AIC</a></span><span class="op">(</span><span class="va">f_parent_saemix_dfop_tc</span><span class="op">$</span><span class="va">so</span><span class="op">)</span></code></pre></div> +<pre><code>[1] 666.1</code></pre> +<div class="sourceCode" id="cb22"><pre class="downlit sourceCode r"> +<code class="sourceCode R"><span class="fu"><a href="https://rdrr.io/r/stats/AIC.html">AIC</a></span><span class="op">(</span><span class="va">f_parent_saemix_dfop_tc</span><span class="op">$</span><span class="va">so</span>, method <span class="op">=</span> <span class="st">"gq"</span><span class="op">)</span></code></pre></div> +<pre><code>[1] 666.03</code></pre> +<div class="sourceCode" id="cb24"><pre class="downlit sourceCode r"> +<code class="sourceCode R"><span class="fu"><a href="https://rdrr.io/r/stats/AIC.html">AIC</a></span><span class="op">(</span><span class="va">f_parent_saemix_dfop_tc</span><span class="op">$</span><span class="va">so</span>, method <span class="op">=</span> <span class="st">"lin"</span><span class="op">)</span></code></pre></div> +<pre><code>[1] 665.48</code></pre> +<p>The AIC values based on importance sampling and Gaussian quadrature are very similar. Using linearisation is known to be less accurate, but still gives a similar value.</p> </div> <div id="nlmixr" class="section level3"> <h3 class="hasAnchor"> <a href="#nlmixr" class="anchor"></a>nlmixr</h3> -<p>In the last years, a lot of effort has been put into the nlmixr package which is designed for pharmacokinetics, where nonlinear mixed-effects models are routinely used, but which can also be used for related data like chemical degradation data. A current development branch of the mkin package provides an interface between mkin and nlmixr. Here, we check if we get equivalent results when using a refined version of the First Order Conditional Estimation (FOCE) algorithm used in nlme, namely First Order Conditional Estimation with Interaction (FOCEI), and the SAEM algorithm as implemented in nlmixr.</p> -<p>First, the focei algorithm is used for the four model combinations and the goodness of fit of the results is compared.</p> -<div class="sourceCode" id="cb25"><pre class="downlit sourceCode r"> +<p>In the last years, a lot of effort has been put into the nlmixr package which is designed for pharmacokinetics, where nonlinear mixed-effects models are routinely used, but which can also be used for related data like chemical degradation data. A current development branch of the mkin package provides an interface between mkin and nlmixr. Here, we check if we get equivalent results when using a refined version of the First Order Conditional Estimation (FOCE) algorithm used in nlme, namely the First Order Conditional Estimation with Interaction (FOCEI), and the SAEM algorithm as implemented in nlmixr.</p> +<p>First, the focei algorithm is used for the four model combinations. A number of warnings are produced with unclear significance.</p> +<div class="sourceCode" id="cb26"><pre class="downlit sourceCode r"> <code class="sourceCode R"><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://github.com/nlmixrdevelopment/nlmixr">nlmixr</a></span><span class="op">)</span> <span class="va">f_parent_nlmixr_focei_sfo_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_parent_mkin_const</span><span class="op">[</span><span class="st">"SFO"</span>, <span class="op">]</span>, est <span class="op">=</span> <span class="st">"focei"</span><span class="op">)</span> <span class="va">f_parent_nlmixr_focei_sfo_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_parent_mkin_tc</span><span class="op">[</span><span class="st">"SFO"</span>, <span class="op">]</span>, est <span class="op">=</span> <span class="st">"focei"</span><span class="op">)</span> <span class="va">f_parent_nlmixr_focei_dfop_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_parent_mkin_const</span><span class="op">[</span><span class="st">"DFOP"</span>, <span class="op">]</span>, est <span class="op">=</span> <span class="st">"focei"</span><span class="op">)</span> <span class="va">f_parent_nlmixr_focei_dfop_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_parent_mkin_tc</span><span class="op">[</span><span class="st">"DFOP"</span>, <span class="op">]</span>, est <span class="op">=</span> <span class="st">"focei"</span><span class="op">)</span></code></pre></div> -<div class="sourceCode" id="cb26"><pre class="downlit sourceCode r"> -<code class="sourceCode R"><span class="fu"><a href="https://rdrr.io/r/stats/AIC.html">AIC</a></span><span class="op">(</span><span class="va">f_parent_nlmixr_focei_sfo_const</span><span class="op">$</span><span class="va">nm</span>, <span class="va">f_parent_nlmixr_focei_sfo_tc</span><span class="op">$</span><span class="va">nm</span>, - <span class="va">f_parent_nlmixr_focei_dfop_const</span><span class="op">$</span><span class="va">nm</span>, <span class="va">f_parent_nlmixr_focei_dfop_tc</span><span class="op">$</span><span class="va">nm</span><span class="op">)</span></code></pre></div> -<pre><code> df AIC -f_parent_nlmixr_focei_sfo_const$nm 5 818.63 -f_parent_nlmixr_focei_sfo_tc$nm 6 820.61 -f_parent_nlmixr_focei_dfop_const$nm 9 728.11 -f_parent_nlmixr_focei_dfop_tc$nm 10 687.82</code></pre> +<div class="sourceCode" id="cb27"><pre class="downlit sourceCode r"> +<code class="sourceCode R"><span class="va">aic_nlmixr_focei</span> <span class="op"><-</span> <span class="fu"><a href="https://rdrr.io/r/base/lapply.html">sapply</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="va">f_parent_nlmixr_focei_sfo_const</span><span class="op">$</span><span class="va">nm</span>, <span class="va">f_parent_nlmixr_focei_sfo_tc</span><span class="op">$</span><span class="va">nm</span>, + <span class="va">f_parent_nlmixr_focei_dfop_const</span><span class="op">$</span><span class="va">nm</span>, <span class="va">f_parent_nlmixr_focei_dfop_tc</span><span class="op">$</span><span class="va">nm</span><span class="op">)</span>, + <span class="va">AIC</span><span class="op">)</span></code></pre></div> <p>The AIC values are very close to the ones obtained with nlme which are repeated below for convenience.</p> <div class="sourceCode" id="cb28"><pre class="downlit sourceCode r"> -<code class="sourceCode R"><span class="fu"><a href="https://rdrr.io/r/stats/AIC.html">AIC</a></span><span class="op">(</span> - <span class="va">f_parent_nlme_sfo_const</span>, <span class="va">f_parent_nlme_sfo_tc</span>, <span class="va">f_parent_nlme_dfop_tc</span> +<code class="sourceCode R"><span class="va">aic_nlme</span> <span class="op"><-</span> <span class="fu"><a href="https://rdrr.io/r/base/lapply.html">sapply</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="va">f_parent_nlme_sfo_const</span>, <span class="cn">NA</span>, <span class="va">f_parent_nlme_sfo_tc</span>, <span class="va">f_parent_nlme_dfop_tc</span><span class="op">)</span>, + <span class="kw">function</span><span class="op">(</span><span class="va">x</span><span class="op">)</span> <span class="kw">if</span> <span class="op">(</span><span class="fu"><a href="https://rdrr.io/r/base/NA.html">is.na</a></span><span class="op">(</span><span class="va">x</span><span class="op">[</span><span class="fl">1</span><span class="op">]</span><span class="op">)</span><span class="op">)</span> <span class="cn">NA</span> <span class="kw">else</span> <span class="fu"><a href="https://rdrr.io/r/stats/AIC.html">AIC</a></span><span class="op">(</span><span class="va">x</span><span class="op">)</span><span class="op">)</span> +<span class="va">aic_nlme_nlmixr_focei</span> <span class="op"><-</span> <span class="fu"><a href="https://rdrr.io/r/base/data.frame.html">data.frame</a></span><span class="op">(</span> + <span class="st">"Degradation model"</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">"SFO"</span>, <span class="st">"DFOP"</span>, <span class="st">"DFOP"</span><span class="op">)</span>, + <span class="st">"Error model"</span> <span class="op">=</span> <span class="fu"><a href="https://rdrr.io/r/base/rep.html">rep</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">"constant variance"</span>, <span class="st">"two-component"</span><span class="op">)</span>, <span class="fl">2</span><span class="op">)</span>, + <span class="st">"AIC (nlme)"</span> <span class="op">=</span> <span class="va">aic_nlme</span>, + <span class="st">"AIC (nlmixr with FOCEI)"</span> <span class="op">=</span> <span class="va">aic_nlmixr_focei</span>, + check.names <span class="op">=</span> <span class="cn">FALSE</span> <span class="op">)</span></code></pre></div> -<pre><code> df AIC -f_parent_nlme_sfo_const 5 818.63 -f_parent_nlme_sfo_tc 6 820.61 -f_parent_nlme_dfop_tc 10 687.84</code></pre> -<p>Secondly, we use the SAEM estimation routine and check the convergence plots for SFO with constant variance</p> +<p>Secondly, we use the SAEM estimation routine and check the convergence plots. The control parameters also used for the saemix fits are defined beforehand.</p> +<div class="sourceCode" id="cb29"><pre class="downlit sourceCode r"> +<code class="sourceCode R"><span class="va">nlmixr_saem_control</span> <span class="op"><-</span> <span class="fu"><a href="https://rdrr.io/pkg/nlmixr/man/saemControl.html">saemControl</a></span><span class="op">(</span>logLik <span class="op">=</span> <span class="cn">TRUE</span>, + nBurn <span class="op">=</span> <span class="fl">1000</span>, nEm <span class="op">=</span> <span class="fl">300</span>, nmc <span class="op">=</span> <span class="fl">15</span><span class="op">)</span></code></pre></div> +<p>The we fit SFO with constant variance</p> <div class="sourceCode" id="cb30"><pre class="downlit sourceCode r"> <code class="sourceCode R"><span class="va">f_parent_nlmixr_saem_sfo_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_parent_mkin_const</span><span class="op">[</span><span class="st">"SFO"</span>, <span class="op">]</span>, est <span class="op">=</span> <span class="st">"saem"</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/saemControl.html">saemControl</a></span><span class="op">(</span>logLik <span class="op">=</span> <span class="cn">TRUE</span><span class="op">)</span><span class="op">)</span> + control <span class="op">=</span> <span class="va">nlmixr_saem_control</span><span class="op">)</span> <span class="fu"><a href="https://rdrr.io/pkg/nlmixr/man/traceplot.html">traceplot</a></span><span class="op">(</span><span class="va">f_parent_nlmixr_saem_sfo_const</span><span class="op">$</span><span class="va">nm</span><span class="op">)</span></code></pre></div> <p><img src="dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_sfo_const-1.png" width="700"></p> -<p>for SFO with two-component error</p> +<p>and SFO with two-component error.</p> <div class="sourceCode" id="cb31"><pre class="downlit sourceCode r"> <code class="sourceCode R"><span class="va">f_parent_nlmixr_saem_sfo_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_parent_mkin_tc</span><span class="op">[</span><span class="st">"SFO"</span>, <span class="op">]</span>, est <span class="op">=</span> <span class="st">"saem"</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/saemControl.html">saemControl</a></span><span class="op">(</span>logLik <span class="op">=</span> <span class="cn">TRUE</span><span class="op">)</span><span class="op">)</span> + control <span class="op">=</span> <span class="va">nlmixr_saem_control</span><span class="op">)</span> <span class="fu"><a href="https://rdrr.io/pkg/nlmixr/man/traceplot.html">traceplot</a></span><span class="op">(</span><span class="va">f_parent_nlmixr_saem_sfo_tc</span><span class="op">$</span><span class="va">nm</span><span class="op">)</span></code></pre></div> <p><img src="dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_sfo_tc-1.png" width="700"></p> -<p>For DFOP with constant variance, the convergence plots show considerable instability of the fit, which can be alleviated by increasing the number of iterations and the number of parallel chains for the first phase of algorithm.</p> +<p>For DFOP with constant variance, the convergence plots show considerable instability of the fit, which indicates overparameterisation which was already observed earlier for this model combination.</p> <div class="sourceCode" id="cb32"><pre class="downlit sourceCode r"> <code class="sourceCode R"><span class="va">f_parent_nlmixr_saem_dfop_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_parent_mkin_const</span><span class="op">[</span><span class="st">"DFOP"</span>, <span class="op">]</span>, est <span class="op">=</span> <span class="st">"saem"</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/saemControl.html">saemControl</a></span><span class="op">(</span>logLik <span class="op">=</span> <span class="cn">TRUE</span>, nBurn <span class="op">=</span> <span class="fl">1000</span><span class="op">)</span>, nmc <span class="op">=</span> <span class="fl">15</span><span class="op">)</span> + control <span class="op">=</span> <span class="va">nlmixr_saem_control</span><span class="op">)</span> <span class="fu"><a href="https://rdrr.io/pkg/nlmixr/man/traceplot.html">traceplot</a></span><span class="op">(</span><span class="va">f_parent_nlmixr_saem_dfop_const</span><span class="op">$</span><span class="va">nm</span><span class="op">)</span></code></pre></div> <p><img src="dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_dfop_const-1.png" width="700"></p> -<p>For DFOP with two-component error, the same increase in iterations and parallel chains was used, but using the two-component error appears to lead to a less erratic convergence, so this may not be necessary to this degree.</p> +<p>For DFOP with two-component error, a less erratic convergence is seen.</p> <div class="sourceCode" id="cb33"><pre class="downlit sourceCode r"> <code class="sourceCode R"><span class="va">f_parent_nlmixr_saem_dfop_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_parent_mkin_tc</span><span class="op">[</span><span class="st">"DFOP"</span>, <span class="op">]</span>, est <span class="op">=</span> <span class="st">"saem"</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/saemControl.html">saemControl</a></span><span class="op">(</span>logLik <span class="op">=</span> <span class="cn">TRUE</span>, nBurn <span class="op">=</span> <span class="fl">1000</span>, nmc <span class="op">=</span> <span class="fl">15</span><span class="op">)</span><span class="op">)</span> + control <span class="op">=</span> <span class="va">nlmixr_saem_control</span><span class="op">)</span> <span class="fu"><a href="https://rdrr.io/pkg/nlmixr/man/traceplot.html">traceplot</a></span><span class="op">(</span><span class="va">f_parent_nlmixr_saem_dfop_tc</span><span class="op">$</span><span class="va">nm</span><span class="op">)</span></code></pre></div> <p><img src="dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_dfop_tc-1.png" width="700"></p> -<p>The AIC values are internally calculated using Gaussian quadrature. For an unknown reason, the AIC value obtained for the DFOP fit using the two-component error model is given as Infinity.</p> +<p>The AIC values are internally calculated using Gaussian quadrature. For an unknown reason, the AIC value obtained for the DFOP fit using constant error is given as Infinity.</p> <div class="sourceCode" id="cb34"><pre class="downlit sourceCode r"> <code class="sourceCode R"><span class="fu"><a href="https://rdrr.io/r/stats/AIC.html">AIC</a></span><span class="op">(</span><span class="va">f_parent_nlmixr_saem_sfo_const</span><span class="op">$</span><span class="va">nm</span>, <span class="va">f_parent_nlmixr_saem_sfo_tc</span><span class="op">$</span><span class="va">nm</span>, <span class="va">f_parent_nlmixr_saem_dfop_const</span><span class="op">$</span><span class="va">nm</span>, <span class="va">f_parent_nlmixr_saem_dfop_tc</span><span class="op">$</span><span class="va">nm</span><span class="op">)</span></code></pre></div> <pre><code> df AIC -f_parent_nlmixr_saem_sfo_const$nm 5 820.54 -f_parent_nlmixr_saem_sfo_tc$nm 6 835.26 -f_parent_nlmixr_saem_dfop_const$nm 9 842.84 -f_parent_nlmixr_saem_dfop_tc$nm 10 684.51</code></pre> +f_parent_nlmixr_saem_sfo_const$nm 5 798.68 +f_parent_nlmixr_saem_sfo_tc$nm 6 808.88 +f_parent_nlmixr_saem_dfop_const$nm 9 815.95 +f_parent_nlmixr_saem_dfop_tc$nm 10 669.57</code></pre> <p>The following table gives the AIC values obtained with the three packages.</p> <div class="sourceCode" id="cb36"><pre class="downlit sourceCode r"> <code class="sourceCode R"><span class="va">AIC_all</span> <span class="op"><-</span> <span class="fu"><a href="https://rdrr.io/r/base/data.frame.html">data.frame</a></span><span class="op">(</span> + check.names <span class="op">=</span> <span class="cn">FALSE</span>, <span class="st">"Degradation model"</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">"SFO"</span>, <span class="st">"DFOP"</span>, <span class="st">"DFOP"</span><span class="op">)</span>, <span class="st">"Error model"</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">"const"</span>, <span class="st">"tc"</span>, <span class="st">"const"</span>, <span class="st">"tc"</span><span class="op">)</span>, nlme <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="fu"><a href="https://rdrr.io/r/stats/AIC.html">AIC</a></span><span class="op">(</span><span class="va">f_parent_nlme_sfo_const</span><span class="op">)</span>, <span class="fu"><a href="https://rdrr.io/r/stats/AIC.html">AIC</a></span><span class="op">(</span><span class="va">f_parent_nlme_sfo_tc</span><span class="op">)</span>, <span class="cn">NA</span>, <span class="fu"><a href="https://rdrr.io/r/stats/AIC.html">AIC</a></span><span class="op">(</span><span class="va">f_parent_nlme_dfop_tc</span><span class="op">)</span><span class="op">)</span>, nlmixr_focei <span class="op">=</span> <span class="fu"><a href="https://rdrr.io/r/base/lapply.html">sapply</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="va">f_parent_nlmixr_focei_sfo_const</span><span class="op">$</span><span class="va">nm</span>, <span class="va">f_parent_nlmixr_focei_sfo_tc</span><span class="op">$</span><span class="va">nm</span>, <span class="va">f_parent_nlmixr_focei_dfop_const</span><span class="op">$</span><span class="va">nm</span>, <span class="va">f_parent_nlmixr_focei_dfop_tc</span><span class="op">$</span><span class="va">nm</span><span class="op">)</span>, <span class="va">AIC</span><span class="op">)</span>, saemix <span class="op">=</span> <span class="fu"><a href="https://rdrr.io/r/base/lapply.html">sapply</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="va">f_parent_saemix_sfo_const</span><span class="op">$</span><span class="va">so</span>, <span class="va">f_parent_saemix_sfo_tc</span><span class="op">$</span><span class="va">so</span>, - <span class="va">f_parent_saemix_dfop_const</span><span class="op">$</span><span class="va">so</span>, <span class="va">f_parent_saemix_dfop_tc_moreiter</span><span class="op">$</span><span class="va">so</span><span class="op">)</span>, <span class="va">AIC</span><span class="op">)</span>, + <span class="va">f_parent_saemix_dfop_const</span><span class="op">$</span><span class="va">so</span>, <span class="va">f_parent_saemix_dfop_tc</span><span class="op">$</span><span class="va">so</span><span class="op">)</span>, <span class="va">AIC</span><span class="op">)</span>, nlmixr_saem <span class="op">=</span> <span class="fu"><a href="https://rdrr.io/r/base/lapply.html">sapply</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="va">f_parent_nlmixr_saem_sfo_const</span><span class="op">$</span><span class="va">nm</span>, <span class="va">f_parent_nlmixr_saem_sfo_tc</span><span class="op">$</span><span class="va">nm</span>, <span class="va">f_parent_nlmixr_saem_dfop_const</span><span class="op">$</span><span class="va">nm</span>, <span class="va">f_parent_nlmixr_saem_dfop_tc</span><span class="op">$</span><span class="va">nm</span><span class="op">)</span>, <span class="va">AIC</span><span class="op">)</span> <span class="op">)</span> <span class="fu">kable</span><span class="op">(</span><span class="va">AIC_all</span><span class="op">)</span></code></pre></div> <table class="table"> <thead><tr class="header"> -<th align="left">Degradation.model</th> -<th align="left">Error.model</th> +<th align="left">Degradation model</th> +<th align="left">Error model</th> <th align="right">nlme</th> <th align="right">nlmixr_focei</th> <th align="right">saemix</th> @@ -355,34 +361,34 @@ f_parent_nlmixr_saem_dfop_tc$nm 10 684.51</code></pre> <tr class="odd"> <td align="left">SFO</td> <td align="left">const</td> -<td align="right">818.63</td> -<td align="right">818.63</td> -<td align="right">818.37</td> -<td align="right">820.54</td> +<td align="right">796.60</td> +<td align="right">796.62</td> +<td align="right">796.37</td> +<td align="right">798.68</td> </tr> <tr class="even"> <td align="left">SFO</td> <td align="left">tc</td> -<td align="right">820.61</td> -<td align="right">820.61</td> -<td align="right">820.38</td> -<td align="right">835.26</td> +<td align="right">798.60</td> +<td align="right">798.61</td> +<td align="right">798.37</td> +<td align="right">808.88</td> </tr> <tr class="odd"> <td align="left">DFOP</td> <td align="left">const</td> <td align="right">NA</td> -<td align="right">728.11</td> -<td align="right">725.91</td> -<td align="right">842.84</td> +<td align="right">750.91</td> +<td align="right">713.16</td> +<td align="right">815.95</td> </tr> <tr class="even"> <td align="left">DFOP</td> <td align="left">tc</td> -<td align="right">687.84</td> -<td align="right">687.82</td> -<td align="right">683.64</td> -<td align="right">684.51</td> +<td align="right">671.91</td> +<td align="right">666.60</td> +<td align="right">666.10</td> +<td align="right">669.57</td> </tr> </tbody> </table> @@ -397,6 +403,9 @@ f_parent_nlmixr_saem_dfop_tc$nm 10 684.51</code></pre> <div id="ref-efsa_2018_dimethenamid"> <p>EFSA. 2018. “Peer Review of the Pesticide Risk Assessment of the Active Substance Dimethenamid-P.” <em>EFSA Journal</em> 16 (4): 5211.</p> </div> +<div id="ref-ranke2021"> +<p>Ranke, Johannes, Janina Wöltjen, Jana Schmidt, and Emmanuelle Comets. 2021. “Taking Kinetic Evaluations of Degradation Data to the Next Level with Nonlinear Mixed-Effects Models.” <em>Environments</em> 8 (8). <a href="https://doi.org/10.3390/environments8080071">https://doi.org/10.3390/environments8080071</a>.</p> +</div> <div id="ref-dimethenamid_rar_2018_b8"> <p>Rapporteur Member State Germany, Co-Rapporteur Member State Bulgaria. 2018. “Renewal Assessment Report Dimethenamid-P Volume 3 - B.8 Environmental fate and behaviour, Rev. 2 - November 2017.” <a href="https://open.efsa.europa.eu/study-inventory/EFSA-Q-2014-00716">https://open.efsa.europa.eu/study-inventory/EFSA-Q-2014-00716</a>.</p> </div> diff --git a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_const-1.png b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_const-1.png Binary files differindex c51afe54..8eb464d1 100644 --- a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_const-1.png +++ b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_const-1.png diff --git a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_const_test-1.png b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_const_test-1.png Binary files differindex 080f0dde..9e4b951a 100644 --- a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_const_test-1.png +++ b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_const_test-1.png diff --git a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_tc_test-1.png b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_tc_test-1.png Binary files differindex a3933e54..830fec65 100644 --- a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_tc_test-1.png +++ b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_dfop_tc_test-1.png diff --git a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_sfo_const-1.png b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_sfo_const-1.png Binary files differindex 8dee2e3c..133249a4 100644 --- a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_sfo_const-1.png +++ b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_mkin_sfo_const-1.png diff --git a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_dfop_const-1.png b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_dfop_const-1.png Binary files differindex 54a8c1a6..db28e43d 100644 --- a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_dfop_const-1.png +++ b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_dfop_const-1.png diff --git a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_dfop_tc-1.png b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_dfop_tc-1.png Binary files differindex 91f3d977..718524e7 100644 --- a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_dfop_tc-1.png +++ b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_dfop_tc-1.png diff --git a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_sfo_const-1.png b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_sfo_const-1.png Binary files differindex c84f2926..9dde6124 100644 --- a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_sfo_const-1.png +++ b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_sfo_const-1.png diff --git a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_sfo_tc-1.png b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_sfo_tc-1.png Binary files differindex cfef9dfc..e2368797 100644 --- a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_sfo_tc-1.png +++ b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_nlmixr_saem_sfo_tc-1.png diff --git a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_dfop_const-1.png b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_dfop_const-1.png Binary files differindex a4695eea..7c79b56c 100644 --- a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_dfop_const-1.png +++ b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_dfop_const-1.png diff --git a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_dfop_tc-1.png b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_dfop_tc-1.png Binary files differnew file mode 100644 index 00000000..8478adcf --- /dev/null +++ b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_dfop_tc-1.png diff --git a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_sfo_const-1.png b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_sfo_const-1.png Binary files differindex 469ebafd..18b546e9 100644 --- a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_sfo_const-1.png +++ b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_sfo_const-1.png diff --git a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_sfo_tc-1.png b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_sfo_tc-1.png Binary files differindex d26bcc09..6a0c05c5 100644 --- a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_sfo_tc-1.png +++ b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/f_parent_saemix_sfo_tc-1.png diff --git a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/plot_parent_nlme-1.png b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/plot_parent_nlme-1.png Binary files differindex 6edeb794..ed978664 100644 --- a/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/plot_parent_nlme-1.png +++ b/docs/dev/articles/web_only/dimethenamid_2018_files/figure-html/plot_parent_nlme-1.png diff --git a/docs/dev/articles/web_only/dimethenamid_2018_files/header-attrs-2.11/header-attrs.js b/docs/dev/articles/web_only/dimethenamid_2018_files/header-attrs-2.11/header-attrs.js new file mode 100644 index 00000000..dd57d92e --- /dev/null +++ b/docs/dev/articles/web_only/dimethenamid_2018_files/header-attrs-2.11/header-attrs.js @@ -0,0 +1,12 @@ +// Pandoc 2.9 adds attributes on both header and div. We remove the former (to +// be compatible with the behavior of Pandoc < 2.8). +document.addEventListener('DOMContentLoaded', function(e) { + var hs = document.querySelectorAll("div.section[class*='level'] > :first-child"); + var i, h, a; + for (i = 0; i < hs.length; i++) { + h = hs[i]; + if (!/^h[1-6]$/i.test(h.tagName)) continue; // it should be a header h1-h6 + a = h.attributes; + while (a.length > 0) h.removeAttribute(a[0].name); + } +}); diff --git a/docs/dev/authors.html b/docs/dev/authors.html index 4208dc24..943cba1b 100644 --- a/docs/dev/authors.html +++ b/docs/dev/authors.html @@ -71,7 +71,7 @@ </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.0.5</span> + <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.1.0</span> </span> </div> diff --git a/docs/dev/index.html b/docs/dev/index.html index 8b0b2386..452d9bdb 100644 --- a/docs/dev/index.html +++ b/docs/dev/index.html @@ -43,7 +43,7 @@ </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.0.5</span> + <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.1.0</span> </span> </div> @@ -264,7 +264,7 @@ Ranke J, Wöltjen J, Meinecke S (2018) Comparison of software tools for kinetic <h2>Dev status</h2> <ul class="list-unstyled"> <li><a href="https://cran.r-project.org/package=mkin"><img src="https://www.r-pkg.org/badges/version/mkin"></a></li> -<li><a href="https://travis-ci.com/jranke/mkin"><img src="https://travis-ci.com/jranke/mkin.svg?branch=master" alt="Build Status"></a></li> +<li><a href="https://app.travis-ci.com/github/jranke/mkin"><img src="https://travis-ci.com/jranke/mkin.svg?branch=master" alt="Build Status"></a></li> <li><a href="https://codecov.io/github/jranke/mkin"><img src="https://codecov.io/github/jranke/mkin/branch/master/graphs/badge.svg" alt="codecov"></a></li> </ul> </div> diff --git a/docs/dev/news/index.html b/docs/dev/news/index.html index 5b153f37..f3cc89d9 100644 --- a/docs/dev/news/index.html +++ b/docs/dev/news/index.html @@ -71,7 +71,7 @@ </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.0.5</span> + <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.1.0</span> </span> </div> @@ -141,9 +141,9 @@ <small>Source: <a href='https://github.com/jranke/mkin/blob/master/NEWS.md'><code>NEWS.md</code></a></small> </div> - <div id="mkin-105-unreleased" class="section level1"> -<h1 class="page-header" data-toc-text="1.0.5"> -<a href="#mkin-105-unreleased" class="anchor"></a>mkin 1.0.5 (unreleased)</h1> + <div id="mkin-110-unreleased" class="section level1"> +<h1 class="page-header" data-toc-text="1.1.0"> +<a href="#mkin-110-unreleased" class="anchor"></a>mkin 1.1.0 (unreleased)</h1> <div id="mixed-effects-models" class="section level2"> <h2 class="hasAnchor"> <a href="#mixed-effects-models" class="anchor"></a>Mixed-effects models</h2> @@ -156,6 +156,13 @@ </ul> </div> </div> + <div id="mkin-105-2021-09-15" class="section level1"> +<h1 class="page-header" data-toc-text="1.0.5"> +<a href="#mkin-105-2021-09-15" class="anchor"></a>mkin 1.0.5 (2021-09-15)</h1> +<ul> +<li>‘dimethenamid_2018’: Correct the data for the Borstel soil. The five observations from Staudenmaier (2013) that were previously stored as “Borstel 2” are actually just a subset of the 16 observations in “Borstel 1” which is now simply “Borstel”</li> +</ul> +</div> <div id="mkin-104-2021-04-20" class="section level1"> <h1 class="page-header" data-toc-text="1.0.4"> <a href="#mkin-104-2021-04-20" class="anchor"></a>mkin 1.0.4 (2021-04-20)</h1> diff --git a/docs/dev/pkgdown.yml b/docs/dev/pkgdown.yml index f184b7a5..e932afd0 100644 --- a/docs/dev/pkgdown.yml +++ b/docs/dev/pkgdown.yml @@ -11,7 +11,7 @@ articles: web_only/benchmarks: benchmarks.html web_only/compiled_models: compiled_models.html web_only/dimethenamid_2018: dimethenamid_2018.html -last_built: 2021-08-04T13:49Z +last_built: 2021-09-16T15:10Z urls: reference: https://pkgdown.jrwb.de/mkin/reference article: https://pkgdown.jrwb.de/mkin/articles diff --git a/docs/dev/reference/dimethenamid_2018-1.png b/docs/dev/reference/dimethenamid_2018-1.png Binary files differindex 52b8a2be..b8c5355f 100644 --- a/docs/dev/reference/dimethenamid_2018-1.png +++ b/docs/dev/reference/dimethenamid_2018-1.png diff --git a/docs/dev/reference/dimethenamid_2018-2.png b/docs/dev/reference/dimethenamid_2018-2.png Binary files differindex a81b2aaf..3b8a123b 100644 --- a/docs/dev/reference/dimethenamid_2018-2.png +++ b/docs/dev/reference/dimethenamid_2018-2.png diff --git a/docs/dev/reference/dimethenamid_2018.html b/docs/dev/reference/dimethenamid_2018.html index a77cf0f4..919e9363 100644 --- a/docs/dev/reference/dimethenamid_2018.html +++ b/docs/dev/reference/dimethenamid_2018.html @@ -77,7 +77,7 @@ constrained by data protection regulations." /> </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.0.5</span> + <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.1.0</span> </span> </div> @@ -162,7 +162,7 @@ constrained by data protection regulations.</p> <h2 class="hasAnchor" id="format"><a class="anchor" href="#format"></a>Format</h2> - <p>An <a href='mkindsg.html'>mkindsg</a> object grouping eight datasets with some meta information</p> + <p>An <a href='mkindsg.html'>mkindsg</a> object grouping seven datasets with some meta information</p> <h2 class="hasAnchor" id="source"><a class="anchor" href="#source"></a>Source</h2> <p>Rapporteur Member State Germany, Co-Rapporteur Member State Bulgaria (2018) @@ -177,42 +177,36 @@ specific pieces of information in the comments.</p> <h2 class="hasAnchor" id="examples"><a class="anchor" href="#examples"></a>Examples</h2> <pre class="examples"><div class='input'><span class='fu'><a href='https://rdrr.io/r/base/print.html'>print</a></span><span class='op'>(</span><span class='va'>dimethenamid_2018</span><span class='op'>)</span> -</div><div class='output co'>#> <mkindsg> holding 8 mkinds objects +</div><div class='output co'>#> <mkindsg> holding 7 mkinds objects #> Title $title: Aerobic soil degradation data on dimethenamid-P from the EU assessment in 2018 #> Occurrence of observed compounds $observed_n: #> DMTAP M23 M27 M31 DMTA -#> 4 7 7 7 4 +#> 3 7 7 7 4 #> Time normalisation factors $f_time_norm: -#> [1] 1.0000000 0.9706477 0.9706477 1.2284784 1.2284784 0.6233856 0.7678922 -#> [8] 0.6733938 +#> [1] 1.0000000 0.9706477 1.2284784 1.2284784 0.6233856 0.7678922 0.6733938 #> Meta information $meta: -#> study usda_soil_type study_moisture_ref_type -#> Calke Unsworth 2014 Sandy loam pF2 -#> Borstel 1 Staudenmaier 2013 Sand pF1 -#> Borstel 2 Staudenmaier 2009 Sand pF1 -#> Elliot 1 Wendt 1997 Clay loam pF2.5 -#> Elliot 2 Wendt 1997 Clay loam pF2.5 -#> Flaach König 1996 Sandy clay loam pF1 -#> BBA 2.2 König 1995 Loamy sand pF1 -#> BBA 2.3 König 1995 Sandy loam pF1 -#> rel_moisture study_ref_moisture temperature -#> Calke 1.00 NA 20 -#> Borstel 1 0.50 23.00 20 -#> Borstel 2 0.50 23.00 20 -#> Elliot 1 0.75 33.37 23 -#> Elliot 2 0.75 33.37 23 -#> Flaach 0.40 NA 20 -#> BBA 2.2 0.40 NA 20 -#> BBA 2.3 0.40 NA 20</div><div class='input'><span class='va'>dmta_ds</span> <span class='op'><-</span> <span class='fu'><a href='https://rdrr.io/r/base/lapply.html'>lapply</a></span><span class='op'>(</span><span class='fl'>1</span><span class='op'>:</span><span class='fl'>8</span>, <span class='kw'>function</span><span class='op'>(</span><span class='va'>i</span><span class='op'>)</span> <span class='op'>{</span> +#> study usda_soil_type study_moisture_ref_type rel_moisture +#> Calke Unsworth 2014 Sandy loam pF2 1.00 +#> Borstel Staudenmaier 2009 Sand pF1 0.50 +#> Elliot 1 Wendt 1997 Clay loam pF2.5 0.75 +#> Elliot 2 Wendt 1997 Clay loam pF2.5 0.75 +#> Flaach König 1996 Sandy clay loam pF1 0.40 +#> BBA 2.2 König 1995 Loamy sand pF1 0.40 +#> BBA 2.3 König 1995 Sandy loam pF1 0.40 +#> study_ref_moisture temperature +#> Calke NA 20 +#> Borstel 23.00 20 +#> Elliot 1 33.37 23 +#> Elliot 2 33.37 23 +#> Flaach NA 20 +#> BBA 2.2 NA 20 +#> BBA 2.3 NA 20</div><div class='input'><span class='va'>dmta_ds</span> <span class='op'><-</span> <span class='fu'><a href='https://rdrr.io/r/base/lapply.html'>lapply</a></span><span class='op'>(</span><span class='fl'>1</span><span class='op'>:</span><span class='fl'>7</span>, <span class='kw'>function</span><span class='op'>(</span><span class='va'>i</span><span class='op'>)</span> <span class='op'>{</span> <span class='va'>ds_i</span> <span class='op'><-</span> <span class='va'>dimethenamid_2018</span><span class='op'>$</span><span class='va'>ds</span><span class='op'>[[</span><span class='va'>i</span><span class='op'>]</span><span class='op'>]</span><span class='op'>$</span><span class='va'>data</span> <span class='va'>ds_i</span><span class='op'>[</span><span class='va'>ds_i</span><span class='op'>$</span><span class='va'>name</span> <span class='op'>==</span> <span class='st'>"DMTAP"</span>, <span class='st'>"name"</span><span class='op'>]</span> <span class='op'><-</span> <span class='st'>"DMTA"</span> <span class='va'>ds_i</span><span class='op'>$</span><span class='va'>time</span> <span class='op'><-</span> <span class='va'>ds_i</span><span class='op'>$</span><span class='va'>time</span> <span class='op'>*</span> <span class='va'>dimethenamid_2018</span><span class='op'>$</span><span class='va'>f_time_norm</span><span class='op'>[</span><span class='va'>i</span><span class='op'>]</span> <span class='va'>ds_i</span> <span class='op'>}</span><span class='op'>)</span> <span class='fu'><a href='https://rdrr.io/r/base/names.html'>names</a></span><span class='op'>(</span><span class='va'>dmta_ds</span><span class='op'>)</span> <span class='op'><-</span> <span class='fu'><a href='https://rdrr.io/r/base/lapply.html'>sapply</a></span><span class='op'>(</span><span class='va'>dimethenamid_2018</span><span class='op'>$</span><span class='va'>ds</span>, <span class='kw'>function</span><span class='op'>(</span><span class='va'>ds</span><span class='op'>)</span> <span class='va'>ds</span><span class='op'>$</span><span class='va'>title</span><span class='op'>)</span> -<span class='va'>dmta_ds</span><span class='op'>[[</span><span class='st'>"Borstel"</span><span class='op'>]</span><span class='op'>]</span> <span class='op'><-</span> <span class='fu'><a href='https://rdrr.io/r/base/cbind.html'>rbind</a></span><span class='op'>(</span><span class='va'>dmta_ds</span><span class='op'>[[</span><span class='st'>"Borstel 1"</span><span class='op'>]</span><span class='op'>]</span>, <span class='va'>dmta_ds</span><span class='op'>[[</span><span class='st'>"Borstel 2"</span><span class='op'>]</span><span class='op'>]</span><span class='op'>)</span> -<span class='va'>dmta_ds</span><span class='op'>[[</span><span class='st'>"Borstel 1"</span><span class='op'>]</span><span class='op'>]</span> <span class='op'><-</span> <span class='cn'>NULL</span> -<span class='va'>dmta_ds</span><span class='op'>[[</span><span class='st'>"Borstel 2"</span><span class='op'>]</span><span class='op'>]</span> <span class='op'><-</span> <span class='cn'>NULL</span> <span class='va'>dmta_ds</span><span class='op'>[[</span><span class='st'>"Elliot"</span><span class='op'>]</span><span class='op'>]</span> <span class='op'><-</span> <span class='fu'><a href='https://rdrr.io/r/base/cbind.html'>rbind</a></span><span class='op'>(</span><span class='va'>dmta_ds</span><span class='op'>[[</span><span class='st'>"Elliot 1"</span><span class='op'>]</span><span class='op'>]</span>, <span class='va'>dmta_ds</span><span class='op'>[[</span><span class='st'>"Elliot 2"</span><span class='op'>]</span><span class='op'>]</span><span class='op'>)</span> <span class='va'>dmta_ds</span><span class='op'>[[</span><span class='st'>"Elliot 1"</span><span class='op'>]</span><span class='op'>]</span> <span class='op'><-</span> <span class='cn'>NULL</span> <span class='va'>dmta_ds</span><span class='op'>[[</span><span class='st'>"Elliot 2"</span><span class='op'>]</span><span class='op'>]</span> <span class='op'><-</span> <span class='cn'>NULL</span> @@ -231,33 +225,33 @@ specific pieces of information in the comments.</p> </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'>#> function () #> { #> ini({ -#> DMTA_0 = 98.7697627680706 -#> eta.DMTA_0 ~ 2.35171765917765 +#> DMTA_0 = 98.7132391714013 +#> eta.DMTA_0 ~ 2.32692496033921 #> log_k_M23 = -3.92162409637283 #> eta.log_k_M23 ~ 0.549278519419884 -#> log_k_M27 = -4.33774620773911 -#> eta.log_k_M27 ~ 0.864474956685295 -#> log_k_M31 = -4.24767627688461 -#> eta.log_k_M31 ~ 0.750297149164171 -#> log_k1 = -2.2341008812259 -#> eta.log_k1 ~ 0.902976221565793 -#> log_k2 = -3.7762779983269 -#> eta.log_k2 ~ 1.57684519529298 -#> g_qlogis = 0.450175725479389 -#> eta.g_qlogis ~ 3.0851335687675 -#> f_DMTA_tffm0_1_qlogis = -2.09240906629456 +#> log_k_M27 = -4.33057580082049 +#> eta.log_k_M27 ~ 0.855184233768426 +#> log_k_M31 = -4.24415516780733 +#> eta.log_k_M31 ~ 0.745746058085877 +#> log_k1 = -2.23515804885306 +#> eta.log_k1 ~ 0.901033446532357 +#> log_k2 = -3.77581484944379 +#> eta.log_k2 ~ 1.57682329638124 +#> g_qlogis = 0.436302910942805 +#> eta.g_qlogis ~ 3.10190528862808 +#> f_DMTA_tffm0_1_qlogis = -2.0914852208395 #> eta.f_DMTA_tffm0_1_qlogis ~ 0.3 -#> f_DMTA_tffm0_2_qlogis = -2.18057573598794 +#> f_DMTA_tffm0_2_qlogis = -2.17879574608926 #> eta.f_DMTA_tffm0_2_qlogis ~ 0.3 -#> f_DMTA_tffm0_3_qlogis = -2.14267187609763 +#> f_DMTA_tffm0_3_qlogis = -2.14036526460782 #> eta.f_DMTA_tffm0_3_qlogis ~ 0.3 -#> sigma_low_DMTA = 0.697933852349996 +#> sigma_low_DMTA = 0.700117227383809 #> rsd_high_DMTA = 0.0257724286053519 -#> sigma_low_M23 = 0.697933852349996 +#> sigma_low_M23 = 0.700117227383809 #> rsd_high_M23 = 0.0257724286053519 -#> sigma_low_M27 = 0.697933852349996 +#> sigma_low_M27 = 0.700117227383809 #> rsd_high_M27 = 0.0257724286053519 -#> sigma_low_M31 = 0.697933852349996 +#> sigma_low_M31 = 0.700117227383809 #> rsd_high_M31 = 0.0257724286053519 #> }) #> model({ @@ -295,7 +289,7 @@ specific pieces of information in the comments.</p> #> M31 ~ add(sigma_low_M31) + prop(rsd_high_M31) #> }) #> } -#> <environment: 0x555559ac3820></div><div class='input'><span class='co'># The focei fit takes about four minutes on my system</span> +#> <environment: 0x555559e97ac0></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> @@ -308,7 +302,7 @@ specific pieces of information in the comments.</p> #> </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 #> </div><div class='output co'>#> <span class='message'>→ optimizing duplicate expressions in EBE model...</span></div><div class='output co'>#> [====|====|====|====|====|====|====|====|====|====] 0:00:00 -#> </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'>Needed Covariates:</span></div><div class='output co'>#> [1] "CMT"</div><div class='output co'>#> <span class='message'>RxODE 1.1.0 using 8 threads (see ?getRxThreads)</span> +#> </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'>Needed Covariates:</span></div><div class='output co'>#> [1] "CMT"</div><div class='output co'>#> <span class='message'>RxODE 1.1.1 using 8 threads (see ?getRxThreads)</span> #> <span class='message'> no cache: create with `rxCreateCache()`</span></div><div class='output co'>#> <span style='font-weight: bold;'>Key:</span> U: Unscaled Parameters; X: Back-transformed parameters; G: Gill difference gradient approximation #> F: Forward difference gradient approximation #> C: Central difference gradient approximation @@ -324,12 +318,12 @@ specific pieces of information in the comments.</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 -#> 232.621 14.126 246.850 </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.0.5 -#> R version used for fitting: 4.1.0 -#> Date of fit: Wed Aug 4 15:53:54 2021 -#> Date of summary: Wed Aug 4 15:53:54 2021 +#> 230.015 8.962 238.957 </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.5 +#> mkin version used for pre-fitting: 1.1.0 +#> R version used for fitting: 4.1.1 +#> Date of fit: Thu Sep 16 14:06:55 2021 +#> Date of summary: Thu Sep 16 14:06:55 2021 #> #> Equations: #> d_DMTA/dt = - ((k1 * g * exp(-k1 * time) + k2 * (1 - g) * exp(-k2 * @@ -346,23 +340,23 @@ specific pieces of information in the comments.</p> #> exp(-k2 * time))) * DMTA - k_M31 * M31 #> #> Data: -#> 568 observations of 4 variable(s) grouped in 6 datasets +#> 563 observations of 4 variable(s) grouped in 6 datasets #> #> Degradation model predictions using RxODE #> -#> Fitted in 246.669 s +#> Fitted in 238.792 s #> #> Variance model: Two-component variance function #> #> Mean of starting values for individual parameters: #> DMTA_0 log_k_M23 log_k_M27 log_k_M31 f_DMTA_ilr_1 f_DMTA_ilr_2 -#> 98.7698 -3.9216 -4.3377 -4.2477 0.1380 0.1393 +#> 98.7132 -3.9216 -4.3306 -4.2442 0.1376 0.1388 #> f_DMTA_ilr_3 log_k1 log_k2 g_qlogis -#> -1.7571 -2.2341 -3.7763 0.4502 +#> -1.7554 -2.2352 -3.7758 0.4363 #> #> Mean of starting values for error model parameters: #> sigma_low rsd_high -#> 0.69793 0.02577 +#> 0.70012 0.02577 #> #> Fixed degradation parameter values: #> None @@ -371,20 +365,20 @@ specific pieces of information in the comments.</p> #> #> Likelihood calculated by focei #> AIC BIC logLik -#> 1936 2031 -945.9 +#> 1918 2014 -937.2 #> #> Optimised parameters: #> est. lower upper -#> DMTA_0 98.7698 98.7356 98.8039 -#> log_k_M23 -3.9216 -3.9235 -3.9197 -#> log_k_M27 -4.3377 -4.3398 -4.3357 -#> log_k_M31 -4.2477 -4.2497 -4.2457 -#> log_k1 -2.2341 -2.2353 -2.2329 -#> log_k2 -3.7763 -3.7781 -3.7744 -#> g_qlogis 0.4502 0.4496 0.4507 -#> f_DMTA_tffm0_1_qlogis -2.0924 -2.0936 -2.0912 -#> f_DMTA_tffm0_2_qlogis -2.1806 -2.1818 -2.1794 -#> f_DMTA_tffm0_3_qlogis -2.1427 -2.1439 -2.1415 +#> DMTA_0 98.7132 98.6801 98.7464 +#> log_k_M23 -3.9216 -3.9235 -3.9198 +#> log_k_M27 -4.3306 -4.3326 -4.3286 +#> log_k_M31 -4.2442 -4.2461 -4.2422 +#> log_k1 -2.2352 -2.2364 -2.2340 +#> log_k2 -3.7758 -3.7776 -3.7740 +#> g_qlogis 0.4363 0.4358 0.4368 +#> f_DMTA_tffm0_1_qlogis -2.0915 -2.0926 -2.0903 +#> f_DMTA_tffm0_2_qlogis -2.1788 -2.1800 -2.1776 +#> f_DMTA_tffm0_3_qlogis -2.1404 -2.1415 -2.1392 #> #> Correlation: #> DMTA_0 l__M23 l__M27 l__M31 log_k1 log_k2 g_qlgs @@ -410,10 +404,10 @@ specific pieces of information in the comments.</p> #> #> Random effects (omega): #> eta.DMTA_0 eta.log_k_M23 eta.log_k_M27 eta.log_k_M31 -#> eta.DMTA_0 2.352 0.0000 0.0000 0.0000 +#> eta.DMTA_0 2.327 0.0000 0.0000 0.0000 #> eta.log_k_M23 0.000 0.5493 0.0000 0.0000 -#> eta.log_k_M27 0.000 0.0000 0.8645 0.0000 -#> eta.log_k_M31 0.000 0.0000 0.0000 0.7503 +#> eta.log_k_M27 0.000 0.0000 0.8552 0.0000 +#> eta.log_k_M31 0.000 0.0000 0.0000 0.7457 #> eta.log_k1 0.000 0.0000 0.0000 0.0000 #> eta.log_k2 0.000 0.0000 0.0000 0.0000 #> eta.g_qlogis 0.000 0.0000 0.0000 0.0000 @@ -425,9 +419,9 @@ specific pieces of information in the comments.</p> #> eta.log_k_M23 0.000 0.000 0.000 #> eta.log_k_M27 0.000 0.000 0.000 #> eta.log_k_M31 0.000 0.000 0.000 -#> eta.log_k1 0.903 0.000 0.000 +#> eta.log_k1 0.901 0.000 0.000 #> eta.log_k2 0.000 1.577 0.000 -#> eta.g_qlogis 0.000 0.000 3.085 +#> eta.g_qlogis 0.000 0.000 3.102 #> eta.f_DMTA_tffm0_1_qlogis 0.000 0.000 0.000 #> eta.f_DMTA_tffm0_2_qlogis 0.000 0.000 0.000 #> eta.f_DMTA_tffm0_3_qlogis 0.000 0.000 0.000 @@ -456,44 +450,44 @@ specific pieces of information in the comments.</p> #> #> Variance model: #> sigma_low rsd_high -#> 0.69793 0.02577 +#> 0.70012 0.02577 #> #> Backtransformed parameters: #> est. lower upper -#> DMTA_0 98.76976 98.73563 98.80390 +#> DMTA_0 98.71324 98.68012 98.74636 #> k_M23 0.01981 0.01977 0.01985 -#> k_M27 0.01307 0.01304 0.01309 -#> k_M31 0.01430 0.01427 0.01433 -#> f_DMTA_to_M23 0.10984 NA NA -#> f_DMTA_to_M27 0.09036 NA NA -#> f_DMTA_to_M31 0.08399 NA NA -#> k1 0.10709 0.10696 0.10722 -#> k2 0.02291 0.02287 0.02295 -#> g 0.61068 0.61055 0.61081 +#> k_M27 0.01316 0.01313 0.01319 +#> k_M31 0.01435 0.01432 0.01438 +#> f_DMTA_to_M23 0.10993 NA NA +#> f_DMTA_to_M27 0.09049 NA NA +#> f_DMTA_to_M31 0.08414 NA NA +#> k1 0.10698 0.10685 0.10710 +#> k2 0.02292 0.02288 0.02296 +#> g 0.60738 0.60725 0.60751 #> #> Resulting formation fractions: #> ff -#> DMTA_M23 0.10984 -#> DMTA_M27 0.09036 -#> DMTA_M31 0.08399 -#> DMTA_sink 0.71581 +#> DMTA_M23 0.10993 +#> DMTA_M27 0.09049 +#> DMTA_M31 0.08414 +#> DMTA_sink 0.71543 #> #> Estimated disappearance times: -#> DT50 DT90 DT50back DT50_k1 DT50_k2 -#> DMTA 10.66 59.78 18 6.473 30.26 -#> M23 34.99 116.24 NA NA NA -#> M27 53.05 176.23 NA NA NA -#> M31 48.48 161.05 NA NA NA</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_dmta_nlmixr_focei</span><span class='op'>)</span> +#> DT50 DT90 DT50back DT50_k1 DT50_k2 +#> DMTA 10.72 60.1 18.09 6.48 30.24 +#> M23 34.99 116.2 NA NA NA +#> M27 52.67 175.0 NA NA NA +#> M31 48.31 160.5 NA NA NA</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_dmta_nlmixr_focei</span><span class='op'>)</span> </div><div class='img'><img src='dimethenamid_2018-1.png' alt='' width='700' height='433' /></div><div class='input'><span class='co'># Using saemix takes about 18 minutes</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_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] "Wed Aug 4 15:53:55 2021" +#> [1] "Thu Sep 16 14:06:56 2021" #> .... #> Minimisation finished -#> [1] "Wed Aug 4 16:12:40 2021"</div><div class='output co'>#> user system elapsed -#> 1192.021 0.064 1192.182 </div><div class='input'> +#> [1] "Thu Sep 16 14:25:28 2021"</div><div class='output co'>#> user system elapsed +#> 1176.278 0.021 1176.388 </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> @@ -504,15 +498,15 @@ specific pieces of information in the comments.</p> <span class='va'>f_dmta_nlmixr_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_dmta_mkin_tc</span>, est <span class='op'>=</span> <span class='st'>"saem"</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/saemControl.html'>saemControl</a></span><span class='op'>(</span>print <span class='op'>=</span> <span class='fl'>500</span>, logLik <span class='op'>=</span> <span class='cn'>TRUE</span>, nmc <span class='op'>=</span> <span class='fl'>9</span><span class='op'>)</span><span class='op'>)</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'>#> 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 -#> 813.299 3.736 151.935 </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='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.3400 -3.5096 -3.3392 -3.7596 -2.2055 -2.7755 1.0281 -2.7872 -2.7223 -2.8341 2.6422 0.7027 0.8124 0.7085 0.8560 1.4980 3.2777 0.3063 0.2850 0.2850 4.1120 0.3716 4.4582 0.3994 4.4820 0.4025 3.7803 0.5780 +#> 500: 97.8212 -4.4030 -4.0872 -4.1289 -2.8278 -4.3505 2.6614 -2.1252 -2.1308 -2.0749 2.9463 1.2933 0.2802 0.3467 0.4814 0.7877 3.0743 0.1508 0.1523 0.3155 0.9557 0.0333 0.4787 0.1073 0.6826 0.0707 0.7849 0.0356</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 +#> 800.784 3.715 149.687 </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.0.5 -#> R version used for fitting: 4.1.0 -#> Date of fit: Wed Aug 4 16:16:18 2021 -#> Date of summary: Wed Aug 4 16:16:18 2021 +</div><div class='output co'>#> nlmixr version used for fitting: 2.0.5 +#> mkin version used for pre-fitting: 1.1.0 +#> R version used for fitting: 4.1.1 +#> Date of fit: Thu Sep 16 14:29:02 2021 +#> Date of summary: Thu Sep 16 14:29:02 2021 #> #> Equations: #> d_DMTA/dt = - ((k1 * g * exp(-k1 * time) + k2 * (1 - g) * exp(-k2 * @@ -529,25 +523,25 @@ specific pieces of information in the comments.</p> #> exp(-k2 * time))) * DMTA - k_M31 * M31 #> #> Data: -#> 568 observations of 4 variable(s) grouped in 6 datasets +#> 563 observations of 4 variable(s) grouped in 6 datasets #> #> Degradation model predictions using RxODE #> -#> Fitted in 151.67 s +#> Fitted in 149.421 s #> #> Variance model: Two-component variance function #> #> Mean of starting values for individual parameters: #> DMTA_0 log_k_M23 log_k_M27 log_k_M31 f_DMTA_ilr_1 f_DMTA_ilr_2 -#> 98.7698 -3.9216 -4.3377 -4.2477 0.1380 0.1393 +#> 98.7132 -3.9216 -4.3306 -4.2442 0.1376 0.1388 #> f_DMTA_ilr_3 log_k1 log_k2 g_qlogis -#> -1.7571 -2.2341 -3.7763 0.4502 +#> -1.7554 -2.2352 -3.7758 0.4363 #> #> Mean of starting values for error model parameters: #> sigma_low_DMTA rsd_high_DMTA sigma_low_M23 rsd_high_M23 sigma_low_M27 -#> 0.69793 0.02577 0.69793 0.02577 0.69793 +#> 0.70012 0.02577 0.70012 0.02577 0.70012 #> rsd_high_M27 sigma_low_M31 rsd_high_M31 -#> 0.02577 0.69793 0.02577 +#> 0.02577 0.70012 0.02577 #> #> Fixed degradation parameter values: #> None @@ -556,32 +550,32 @@ specific pieces of information in the comments.</p> #> #> Likelihood calculated by focei #> AIC BIC logLik -#> 2036 2157 -989.8 +#> 1953 2074 -948.3 #> #> Optimised parameters: #> est. lower upper -#> DMTA_0 97.828 96.121 99.535 -#> log_k_M23 -4.351 -5.300 -3.401 -#> log_k_M27 -4.032 -4.470 -3.594 -#> log_k_M31 -4.152 -4.689 -3.615 -#> log_k1 -3.055 -3.785 -2.325 -#> log_k2 -3.584 -4.517 -2.651 -#> g_qlogis 1.133 -2.165 4.430 -#> f_DMTA_tffm0_1_qlogis -2.087 -2.407 -1.768 -#> f_DMTA_tffm0_2_qlogis -2.042 -2.336 -1.748 -#> f_DMTA_tffm0_3_qlogis -2.075 -2.557 -1.593 +#> DMTA_0 97.821 95.862 99.780 +#> log_k_M23 -4.403 -5.376 -3.430 +#> log_k_M27 -4.087 -4.545 -3.629 +#> log_k_M31 -4.129 -4.639 -3.618 +#> log_k1 -2.828 -3.389 -2.266 +#> log_k2 -4.351 -5.472 -3.229 +#> g_qlogis 2.661 0.824 4.499 +#> f_DMTA_tffm0_1_qlogis -2.125 -2.449 -1.801 +#> f_DMTA_tffm0_2_qlogis -2.131 -2.468 -1.794 +#> f_DMTA_tffm0_3_qlogis -2.075 -2.540 -1.610 #> #> Correlation: #> DMTA_0 l__M23 l__M27 l__M31 log_k1 log_k2 g_qlgs -#> log_k_M23 -0.031 -#> log_k_M27 -0.050 0.004 -#> log_k_M31 -0.032 0.003 0.078 -#> log_k1 0.014 -0.002 -0.002 -0.001 -#> log_k2 0.059 0.006 -0.001 0.002 -0.037 -#> g_qlogis -0.077 0.005 0.009 0.004 0.035 -0.201 -#> f_DMTA_tffm0_1_qlogis -0.104 0.066 0.009 0.006 0.000 -0.011 0.014 -#> f_DMTA_tffm0_2_qlogis -0.120 0.013 0.081 -0.033 -0.002 -0.013 0.017 -#> f_DMTA_tffm0_3_qlogis -0.086 0.010 0.060 0.078 -0.002 -0.005 0.010 +#> log_k_M23 -0.019 +#> log_k_M27 -0.028 0.004 +#> log_k_M31 -0.019 0.003 0.075 +#> log_k1 0.038 -0.004 -0.006 -0.003 +#> log_k2 0.046 0.011 0.008 0.009 0.068 +#> g_qlogis -0.067 0.004 0.006 0.001 -0.076 -0.409 +#> f_DMTA_tffm0_1_qlogis -0.062 0.055 0.006 0.004 -0.008 -0.004 0.012 +#> f_DMTA_tffm0_2_qlogis -0.062 0.010 0.058 -0.034 -0.008 -0.007 0.014 +#> f_DMTA_tffm0_3_qlogis -0.052 0.009 0.056 0.071 -0.006 -0.001 0.008 #> f_DMTA_0_1 f_DMTA_0_2 #> log_k_M23 #> log_k_M27 @@ -590,15 +584,15 @@ specific pieces of information in the comments.</p> #> log_k2 #> g_qlogis #> f_DMTA_tffm0_1_qlogis -#> f_DMTA_tffm0_2_qlogis 0.026 -#> f_DMTA_tffm0_3_qlogis 0.019 0.002 +#> f_DMTA_tffm0_2_qlogis 0.017 +#> f_DMTA_tffm0_3_qlogis 0.014 -0.005 #> #> Random effects (omega): #> eta.DMTA_0 eta.log_k_M23 eta.log_k_M27 eta.log_k_M31 -#> eta.DMTA_0 0.296 0.000 0.0000 0.0000 -#> eta.log_k_M23 0.000 1.252 0.0000 0.0000 -#> eta.log_k_M27 0.000 0.000 0.2531 0.0000 -#> eta.log_k_M31 0.000 0.000 0.0000 0.3807 +#> eta.DMTA_0 2.946 0.000 0.0000 0.0000 +#> eta.log_k_M23 0.000 1.293 0.0000 0.0000 +#> eta.log_k_M27 0.000 0.000 0.2802 0.0000 +#> eta.log_k_M31 0.000 0.000 0.0000 0.3467 #> eta.log_k1 0.000 0.000 0.0000 0.0000 #> eta.log_k2 0.000 0.000 0.0000 0.0000 #> eta.g_qlogis 0.000 0.000 0.0000 0.0000 @@ -610,9 +604,9 @@ specific pieces of information in the comments.</p> #> eta.log_k_M23 0.0000 0.0000 0.000 #> eta.log_k_M27 0.0000 0.0000 0.000 #> eta.log_k_M31 0.0000 0.0000 0.000 -#> eta.log_k1 0.7928 0.0000 0.000 -#> eta.log_k2 0.0000 0.8863 0.000 -#> eta.g_qlogis 0.0000 0.0000 6.521 +#> eta.log_k1 0.4814 0.0000 0.000 +#> eta.log_k2 0.0000 0.7877 0.000 +#> eta.g_qlogis 0.0000 0.0000 3.074 #> eta.f_DMTA_tffm0_1_qlogis 0.0000 0.0000 0.000 #> eta.f_DMTA_tffm0_2_qlogis 0.0000 0.0000 0.000 #> eta.f_DMTA_tffm0_3_qlogis 0.0000 0.0000 0.000 @@ -624,8 +618,8 @@ specific pieces of information in the comments.</p> #> eta.log_k1 0.0000 0.0000 #> eta.log_k2 0.0000 0.0000 #> eta.g_qlogis 0.0000 0.0000 -#> eta.f_DMTA_tffm0_1_qlogis 0.1433 0.0000 -#> eta.f_DMTA_tffm0_2_qlogis 0.0000 0.1082 +#> eta.f_DMTA_tffm0_1_qlogis 0.1508 0.0000 +#> eta.f_DMTA_tffm0_2_qlogis 0.0000 0.1523 #> eta.f_DMTA_tffm0_3_qlogis 0.0000 0.0000 #> eta.f_DMTA_tffm0_3_qlogis #> eta.DMTA_0 0.0000 @@ -637,40 +631,40 @@ specific pieces of information in the comments.</p> #> eta.g_qlogis 0.0000 #> eta.f_DMTA_tffm0_1_qlogis 0.0000 #> eta.f_DMTA_tffm0_2_qlogis 0.0000 -#> eta.f_DMTA_tffm0_3_qlogis 0.3353 +#> eta.f_DMTA_tffm0_3_qlogis 0.3155 #> #> Variance model: #> sigma_low_DMTA rsd_high_DMTA sigma_low_M23 rsd_high_M23 sigma_low_M27 -#> 0.89603 0.04704 0.75015 0.04753 0.95265 +#> 0.95572 0.03325 0.47871 0.10733 0.68264 #> rsd_high_M27 sigma_low_M31 rsd_high_M31 -#> 0.02810 0.73212 0.05942 +#> 0.07072 0.78486 0.03557 #> #> Backtransformed parameters: #> est. lower upper -#> DMTA_0 97.82774 96.120503 99.53498 -#> k_M23 0.01290 0.004991 0.03334 -#> k_M27 0.01774 0.011451 0.02749 -#> k_M31 0.01573 0.009195 0.02692 -#> f_DMTA_to_M23 0.11033 NA NA -#> f_DMTA_to_M27 0.10218 NA NA -#> f_DMTA_to_M31 0.08784 NA NA -#> k1 0.04711 0.022707 0.09773 -#> k2 0.02775 0.010918 0.07056 -#> g 0.75632 0.102960 0.98823 +#> DMTA_0 97.82122 95.862233 99.78020 +#> k_M23 0.01224 0.004625 0.03239 +#> k_M27 0.01679 0.010615 0.02654 +#> k_M31 0.01610 0.009664 0.02683 +#> f_DMTA_to_M23 0.10668 NA NA +#> f_DMTA_to_M27 0.09481 NA NA +#> f_DMTA_to_M31 0.08908 NA NA +#> k1 0.05914 0.033731 0.10370 +#> k2 0.01290 0.004204 0.03958 +#> g 0.93471 0.695081 0.98900 #> #> Resulting formation fractions: #> ff -#> DMTA_M23 0.11033 -#> DMTA_M27 0.10218 -#> DMTA_M31 0.08784 -#> DMTA_sink 0.69965 +#> DMTA_M23 0.10668 +#> DMTA_M27 0.09481 +#> DMTA_M31 0.08908 +#> DMTA_sink 0.70943 #> #> Estimated disappearance times: #> DT50 DT90 DT50back DT50_k1 DT50_k2 -#> DMTA 16.59 57.44 17.29 14.71 24.97 -#> M23 53.74 178.51 NA NA NA -#> M27 39.07 129.78 NA NA NA -#> M31 44.06 146.36 NA NA NA</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_dmta_nlmixr_saem</span><span class='op'>)</span> +#> DMTA 12.57 45.43 13.67 11.72 53.73 +#> M23 56.63 188.11 NA NA NA +#> M27 41.29 137.18 NA NA NA +#> M31 43.05 143.01 NA NA NA</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_dmta_nlmixr_saem</span><span class='op'>)</span> </div><div class='img'><img src='dimethenamid_2018-2.png' alt='' width='700' height='433' /></div><div class='input'><span class='co'># }</span> </div></pre> </div> diff --git a/docs/dev/reference/endpoints.html b/docs/dev/reference/endpoints.html index dc1d1f17..aa5bd773 100644 --- a/docs/dev/reference/endpoints.html +++ b/docs/dev/reference/endpoints.html @@ -78,7 +78,7 @@ advantage that the SFORB model can also be used for metabolites." /> </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.0.5</span> + <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.1.0</span> </span> </div> diff --git a/docs/dev/reference/index.html b/docs/dev/reference/index.html index bb030605..d5ec387a 100644 --- a/docs/dev/reference/index.html +++ b/docs/dev/reference/index.html @@ -71,7 +71,7 @@ </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.0.5</span> + <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.1.0</span> </span> </div> diff --git a/docs/dev/reference/mean_degparms.html b/docs/dev/reference/mean_degparms.html index f63dbc31..5981c625 100644 --- a/docs/dev/reference/mean_degparms.html +++ b/docs/dev/reference/mean_degparms.html @@ -72,7 +72,7 @@ </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.0.5</span> + <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.1.0</span> </span> </div> diff --git a/docs/dev/reference/mkinmod.html b/docs/dev/reference/mkinmod.html index ac7c2daa..6478cda4 100644 --- a/docs/dev/reference/mkinmod.html +++ b/docs/dev/reference/mkinmod.html @@ -76,7 +76,7 @@ components." /> </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.0.5</span> + <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.1.0</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/RtmpKZJMFk/file179ba717d15c81.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/RtmpTzKqT5/file7993c266a7f90.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: 0x555559c54f78></div><div class='input'> +#> <environment: 0x555559365690></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 365aaef0..e4bc2fde 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 40841404..31910ce4 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 55a94443..500ac391 100644 --- a/docs/dev/reference/nlme.html +++ b/docs/dev/reference/nlme.html @@ -75,7 +75,7 @@ datasets. They are used internally by the nlme.mmkin() method." /> </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.0.5</span> + <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.1.0</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 -#> 300.6824 310.2426 -145.3412 +#> 289.8295 299.4886 -139.9148 #> #> Random effects: #> Formula: list(parent_0 ~ 1, log_k_parent_sink ~ 1) #> Level: ds #> Structure: Diagonal #> parent_0 log_k_parent_sink Residual -#> StdDev: 1.697361 0.6801209 3.666073 +#> StdDev: 1.839278 0.6988919 3.059894 #> #> Fixed effects: parent_0 + log_k_parent_sink ~ 1 #> Value Std.Error DF t-value p-value -#> parent_0 100.99378 1.3890416 46 72.70753 0 -#> log_k_parent_sink -3.07521 0.4018589 46 -7.65246 0 +#> parent_0 100.52780 1.3507449 47 74.42397 0 +#> log_k_parent_sink -3.08477 0.4124053 47 -7.47995 0 #> Correlation: #> prnt_0 -#> log_k_parent_sink 0.027 +#> log_k_parent_sink 0.019 #> #> Standardized Within-Group Residuals: -#> Min Q1 Med Q3 Max -#> -1.9942823 -0.5622565 0.1791579 0.7165038 2.0704781 +#> Min Q1 Med Q3 Max +#> -2.22350411 -0.51546184 0.04803417 0.55987705 3.49178405 #> -#> Number of Observations: 50 +#> Number of Observations: 51 #> Number of Groups: 3 </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 db863392..866091ca 100644 --- a/docs/dev/reference/nlme.mmkin.html +++ b/docs/dev/reference/nlme.mmkin.html @@ -74,7 +74,7 @@ have been obtained by fitting the same model to a list of datasets." /> </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.0.5</span> + <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.1.0</span> </span> </div> diff --git a/docs/dev/reference/nlmixr.mmkin.html b/docs/dev/reference/nlmixr.mmkin.html index 99a7ad14..db114483 100644 --- a/docs/dev/reference/nlmixr.mmkin.html +++ b/docs/dev/reference/nlmixr.mmkin.html @@ -74,7 +74,7 @@ Expectation Maximisation algorithm (SAEM)." /> </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.0.5</span> + <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.1.0</span> </span> </div> @@ -4416,7 +4416,8 @@ obtained by fitting the same model to a list of datasets using <a href='mkinfit. #> |.....................| 5.960e-07 | 0.6941 | 1.222 | 1.493 | #> | X|<span style='font-weight: bold;'> 288.66432</span> | 94.40 | 0.8038 | 7.793 | 2.283 | #> |.....................| 5.960e-07 | 0.6941 | 1.222 | 1.493 | -#> 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: ETAs were reset to zero during optimization; (Can control by foceiControl(resetEtaP=.))</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: parameter estimate near boundary; covariance not calculated</span> +#> 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: ETAs were reset to zero during optimization; (Can control by foceiControl(resetEtaP=.))</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: parameter estimate near boundary; covariance not calculated:</span> +#> <span class='warning'> "rsd_high" </span> #> <span class='warning'> use 'getVarCov' to calculate anyway</span></div><div class='output co'>#> <span class='warning'>Warning: gradient problems with initial estimate; see $scaleInfo</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_saem</span><span class='op'>$</span><span class='va'>nm</span>, <span class='va'>f_nlmixr_sfo_focei</span><span class='op'>$</span><span class='va'>nm</span>, @@ -4501,7 +4502,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.723 0.414 6.136</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.579 0.328 5.909</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 +4551,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.874 0.399 7.27</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.125 0.34 7.462</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 +4608,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: 14.83 0.382 15.21</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.03 0.407 15.43</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.22 0.146 1.365</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.253 0.121 1.373</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 +4660,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.6 0.416 7.016</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.551 0.126 1.673</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.487 0.387 6.872</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.385 0.1 1.485</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 +4718,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: 15.24 0.429 15.67</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.06 0.434 15.49</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 +4772,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.644 0.416 9.058</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.599 0.38 8.975</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 +4831,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.76 0.426 19.18</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: 17.64 0.453 18.09</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.757 0.072 0.829</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.772 0.04 0.813</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 +4888,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.417 0.388 8.803</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.33 0.419 8.745</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.82 0.035 0.857</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.832 0.032 0.866</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 +4950,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.61 0.452 18.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: 18.15 0.42 18.57</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 746a8640..9f0eb965 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.0.5</span> + <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.1.0</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] "Wed Aug 4 16:21:52 2021" +#> [1] "Thu Sep 16 14:34:31 2021" #> .... #> Minimisation finished -#> [1] "Wed Aug 4 16:22:00 2021"</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 Sep 16 14:34:38 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 f5ace044..ac4fa4d9 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.0.5</span> + <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.1.0</span> </span> </div> diff --git a/docs/dev/reference/saem.html b/docs/dev/reference/saem.html index 620173b2..8d986126 100644 --- a/docs/dev/reference/saem.html +++ b/docs/dev/reference/saem.html @@ -74,7 +74,7 @@ Expectation Maximisation algorithm (SAEM)." /> </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.0.5</span> + <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.1.0</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] "Wed Aug 4 16:22:05 2021" +#> [1] "Thu Sep 16 14:34:42 2021" #> .... #> Minimisation finished -#> [1] "Wed Aug 4 16:22:06 2021"</div><div class='input'> +#> [1] "Thu Sep 16 14:34:43 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] "Wed Aug 4 16:22:08 2021" +#> [1] "Thu Sep 16 14:34:45 2021" #> .... #> Minimisation finished -#> [1] "Wed Aug 4 16:22:10 2021"</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 Sep 16 14:34:47 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] "Wed Aug 4 16:22:10 2021" +#> [1] "Thu Sep 16 14:34:47 2021" #> .... #> Minimisation finished -#> [1] "Wed Aug 4 16:22:12 2021"</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 Sep 16 14:34:49 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] "Wed Aug 4 16:22:12 2021" +#> [1] "Thu Sep 16 14:34:49 2021" #> .... #> Minimisation finished -#> [1] "Wed Aug 4 16:22:16 2021"</div><div class='input'> +#> [1] "Thu Sep 16 14:34:52 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] "Wed Aug 4 16:22:19 2021" +#> [1] "Thu Sep 16 14:34:55 2021" #> .... #> Minimisation finished -#> [1] "Wed Aug 4 16:22:24 2021"</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 Sep 16 14:35:00 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] "Wed Aug 4 16:22:27 2021" +#> [1] "Thu Sep 16 14:35:03 2021" #> .... #> Minimisation finished -#> [1] "Wed Aug 4 16:22:32 2021"</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 Sep 16 14:35:08 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] "Wed Aug 4 16:22:33 2021" +#> [1] "Thu Sep 16 14:35:08 2021" #> .... #> Minimisation finished -#> [1] "Wed Aug 4 16:22:42 2021"</div><div class='input'><span class='co'># We can use print, plot and summary methods to check the results</span> +#> [1] "Thu Sep 16 14:35:17 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.0.5 -#> R version used for fitting: 4.1.0 -#> Date of fit: Wed Aug 4 16:22:43 2021 -#> Date of summary: Wed Aug 4 16:22:43 2021 +#> mkin version used for pre-fitting: 1.1.0 +#> R version used for fitting: 4.1.1 +#> Date of fit: Thu Sep 16 14:35:18 2021 +#> Date of summary: Thu Sep 16 14:35:18 2021 #> #> Equations: #> d_parent/dt = - ((k1 * g * exp(-k1 * time) + k2 * (1 - g) * exp(-k2 * @@ -448,7 +448,7 @@ using <a href='mmkin.html'>mmkin</a>.</p> #> #> Model predictions using solution type analytical #> -#> Fitted in 10.143 s using 300, 100 iterations +#> Fitted in 9.349 s using 300, 100 iterations #> #> Variance model: Constant variance #> diff --git a/docs/dev/reference/summary.nlmixr.mmkin.html b/docs/dev/reference/summary.nlmixr.mmkin.html index 70a71683..4831bbdf 100644 --- a/docs/dev/reference/summary.nlmixr.mmkin.html +++ b/docs/dev/reference/summary.nlmixr.mmkin.html @@ -76,7 +76,7 @@ endpoints such as formation fractions and DT50 values. Optionally </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.0.5</span> + <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.1.0</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] "Wed Aug 4 16:22:46 2021" +#> [1] "Thu Sep 16 14:35:21 2021" #> .... #> Minimisation finished -#> [1] "Wed Aug 4 16:22:59 2021"</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 Sep 16 14:35:33 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.383 0.12 1.503</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.412 0.101 1.525</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: 18.43 0.422 18.87</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: 18.28 0.455 18.73</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/tffm0.html b/docs/dev/reference/tffm0.html index d993e8ff..67f26b85 100644 --- a/docs/dev/reference/tffm0.html +++ b/docs/dev/reference/tffm0.html @@ -81,7 +81,7 @@ from RxODE." /> </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.0.5</span> + <span class="version label label-info" data-toggle="tooltip" data-placement="bottom" title="In-development version">1.1.0</span> </span> </div> |
