added working faser ME eval

NAMESPACE

@@ -128,6 +128,7 @@ S3method(rxUiGet,popedNotfixedBpop)
 S3method(rxUiGet,popedNotfixedCovd)
 S3method(rxUiGet,popedNotfixedD)
 S3method(rxUiGet,popedNotfixedSigma)
+S3method(rxUiGet,popedOptsw)
 S3method(rxUiGet,popedParameters)
 S3method(rxUiGet,popedRxmodelBase)
 S3method(rxUiGet,popedScriptBeforeCtl)
@@ -174,6 +175,9 @@ export(nonmemControl)
 export(pkncaControl)
 export(popedControl)
 export(popedMultipleEndpointIndexDataFrame)
+export(popedMultipleEndpointIsLastTimeSetup)
+export(popedMultipleEndpointParam)
+export(popedMultipleEndpointResetTimeIndex)
 export(rxModelVars)
 export(rxToMonolix)
 export(rxToNonmem)

R/RcppExports.R

@@ -13,22 +13,34 @@ convertDataBack <- function(id, time, amt, ii, evid, cmt, cmtDvid, dvidDvid, lin
 #'   of IDs, groups the times by their IDs, initializes an internal
 #'   C++ global TimeIndexer, that is used to efficiently lookup the
 #'   final output from the rxode2 solve and then returns the sorted
-#'   unique times
+#'   unique times.
+#'
+#' The `popedMultipleEndpointIndexDataFrame()` function can be used
+#'   to visualize the internal data structure inside R, but it does
+#'   not show all the indexes in the case of time ties for a given
+#'   ID.  Rather it shows one of the indexs and the total number of
+#'   indexes in the data.frame
 #'
 #' @param times A numeric vector of times.
 #'
 #' @param modelSwitch An integer vector of model switch indicator
 #'   corresponding to the times
 #'
-#' @return A numeric vector of sorted unique times.
+#' @param sorted A boolean indicating if the returned times should be sorted
+#'
+#' @param print boolean for `popedMultipleEndpointIndexDataFrame()`
+#'   when `TRUE` show each id/index per time even though it may not
+#'   reflect in the returned data.frame
+#'
+#' @return A numeric vector of unique times.
 #'
 #' @examples
 #'
 #' \donttest{
 #'
 #' times <- c(1.1, 1.2, 1.3, 2.1, 2.2, 3.1)
 #' modelSwitch <- c(1, 1, 1, 2, 2, 3)
-#' sortedTimes <- popedGetMultipleEndpointModelingTimes(times, modelSwitch)
+#' sortedTimes <- popedGetMultipleEndpointModelingTimes(times, modelSwitch, TRUE)
 #' print(sortedTimes)
 #'
 #' # now show the output of the data frame representing the model
@@ -40,14 +52,14 @@ convertDataBack <- function(id, time, amt, ii, evid, cmt, cmtDvid, dvidDvid, lin
 #'
 #' times <- c(1.1, 1.2, 1.3, 0.5, 2.2, 1.1, 0.75,0.75)
 #' modelSwitch <- c(1, 1, 1, 2, 2, 2, 3, 3)
-#' sortedTimes <- popedGetMultipleEndpointModelingTimes(times, modelSwitch)
+#' sortedTimes <- popedGetMultipleEndpointModelingTimes(times, modelSwitch, TRUE)
 #' print(sortedTimes)
 #'
 #' popedMultipleEndpointIndexDataFrame()
 #'
 #' }
-popedGetMultipleEndpointModelingTimes <- function(times, modelSwitch) {
-    .Call(`_babelmixr2_popedGetMultipleEndpointModelingTimes`, times, modelSwitch)
+popedGetMultipleEndpointModelingTimes <- function(times, modelSwitch, sorted = FALSE) {
+    .Call(`_babelmixr2_popedGetMultipleEndpointModelingTimes`, times, modelSwitch, sorted)
 }
 
 #' @title Reset the Global Time Indexer for Multiple Endpoint Modeling
@@ -59,9 +71,11 @@ popedGetMultipleEndpointModelingTimes <- function(times, modelSwitch) {
 #'
 #' @return NULL, called for side effects
 #'
+#' @export
+#'
 #' @examples
 #'
-#' \donttest{
+#' \dontrun{
 #'
 #' popedMultipleEndpointResetTimeIndex()
 #'
@@ -72,8 +86,67 @@ popedMultipleEndpointResetTimeIndex <- function() {
 
 #' @rdname popedGetMultipleEndpointModelingTimes
 #' @export
-popedMultipleEndpointIndexDataFrame <- function() {
-    .Call(`_babelmixr2_popedMultipleEndpointIndexDataFrame`)
+popedMultipleEndpointIndexDataFrame <- function(print = FALSE) {
+    .Call(`_babelmixr2_popedMultipleEndpointIndexDataFrame`, print)
+}
+
+#' Populates Multiple Endpoint Parameters for internal solving
+#'
+#' This function populates a numeric vector with parameters and
+#' unique times and also populates the internal C++ global index
+#'
+#' @param p A numeric vector of parameters
+#'
+#' @param times A numeric vector of times
+#'
+#' @param modelSwitch An integer vector indicating model switches from PopED
+#'
+#' @param maxMT An integer specifying the maximum number of time
+#'   points in the mtimes model
+#'
+#' @return A numeric vector containing the parameters followed by
+#'   unique times, if the maximum number of times is greater than the
+#'   input this will append the maximum observed times in the
+#'   input. This assumes the first parameter is the id and is dropped
+#'   fro the output.
+#'
+#' @details
+#'
+#'  - This function first uses the input times and model switches to
+#'   a global time indexer.
+#'
+#'  - It then creates a new numeric vector
+#'    that combines the input parameters and unique times.  If the
+#'    number of times is less than `maxMT`, the remaining elements are
+#'    filled with the maximum time.
+#'
+#' @examples
+#' \dontrun{
+#'
+#' p <- c(1.0, 2.0, 3.0)
+#' times <- c(0.5, 1.5, 2.5)
+#' modelSwitch <- c(1, 2, 3)
+#' maxMT <- 5
+#' popedMultipleEndpointParam(p, times, modelSwitch, maxMT)
+#'
+#' }
+#' @export
+#' @keywords internal
+#' @author Matthew L. Fidler
+popedMultipleEndpointParam <- function(p, times, modelSwitch, maxMT) {
+    .Call(`_babelmixr2_popedMultipleEndpointParam`, p, times, modelSwitch, maxMT)
+}
+
+#' @title Get the Last Time Vector setup for Multiple Endpoint Modeling
+#'
+#' @param times A numeric vector of times
+#'
+#' @return boolean indicating if the last time vector setup is the
+#'   same as what is currently setup
+#'
+#' @export
+popedMultipleEndpointIsLastTimeSetup <- function(times) {
+    .Call(`_babelmixr2_popedMultipleEndpointIsLastTimeSetup`, times)
 }
 
 popedFree <- function() {

R/poped.R

@@ -440,25 +440,25 @@ rxUiGet.popedFfFun <- function(x, ...) {
     .body <- bquote({
       .xt <- drop(xt)
       .id <- p[1]
-      .p <- p[-1]
       .u <- .xt
       .lu <- length(.u)
       .totn <- length(.xt)
       # unlike standard rxode2, parameters need not be named, but must be in the right order
-      if (.lu <  .(.poped$maxn)) {
-        .p <- c(.p, .u, seq(.(.poped$mt), by=0.1, length.out=.(.poped$maxn) - .lu))
+      if (.lu <=  .(.poped$maxn)) {
+        # only check for time reset if it is specified in the model
+        if (poped.db$settings$optsw[2] && !babelmixr2::popedMultipleEndpointIsLastTimeSetup(.u)) {
+          babelmixr2::popedMultipleEndpointResetTimeIndex()
+        }
+        .p <- babelmixr2::popedMultipleEndpointParam(p, .u, model_switch,
+                                                     .(.poped$maxn))
         .popedRxRunSetup(poped.db)
         .ret <- .popedSolveIdME(.p, .u, .xt, model_switch, .(length(.predDf$cond)),
-                                            .id-1, .totn)
+                                .id-1, .totn)
       } else if (.lu > .(.poped$maxn)) {
+        .p <- p[-1]
         .popedRxRunFullSetupMe(poped.db, .xt, model_switch)
         .ret <- .popedSolveIdME2(.p, .u, .xt, model_switch, .(length(.predDf$cond)),
                                              .id-1, .totn)
-      } else {
-        .p <- c(.p, .u)
-        .popedRxRunSetup(poped.db)
-        .ret <- .popedSolveIdME(.p, .u, .xt, model_switch, .(length(.predDf$cond)),
-                                            .id-1, .totn)
       }
       return(list(f=matrix(.ret$rx_pred_, ncol=1),
                   poped.db=poped.db))
@@ -522,7 +522,7 @@ attr(rxUiGet.popedFfFun, "desc") <- "PopED parameter model (ff_fun)"
   } else {
     .poped$lastEnv <- popedDb$babelmixr2
   }
-  if (length(popedDb$curNumber) != 1L) {
+  if (!identical(.poped$lastEnv, popedDb$babelmixr2)) {
     .poped$setup <- 0L
   } else if (length(popedDb$babelmixr2$modelNumber) != 1L) {
     .poped$setup <- 0L
@@ -532,8 +532,8 @@ attr(rxUiGet.popedFfFun, "desc") <- "PopED parameter model (ff_fun)"
   if (.poped$setup != 1L) {
     rxode2::rxSolveFree()
     .popedSetup(popedDb$babelmixr2, FALSE)
-    .poped$setup <- 1L
     .poped$curNumber <- popedDb$babelmixr2$modelNumber
+    .poped$setup <- 1L
     .poped$fullXt <- NULL
   }
   invisible()
@@ -1724,6 +1724,17 @@ rxUiGet.popedSettings <- function(x, ...) {
   .poped$dataMT <- rxode2::etTrans(.dat, .poped$modelMT)
 }
 
+#' @export
+rxUiGet.popedOptsw <- function(x, ...) {
+  .ui <- x[[1]]
+  c(rxode2::rxGetControl(.ui, "opt_samps", FALSE)*1, #1
+    rxode2::rxGetControl(.ui, "opt_xt", FALSE)*1, # 2
+    rxode2::rxGetControl(.ui, "opt_x", FALSE)*1, # 3
+    rxode2::rxGetControl(.ui, "opt_a", FALSE)*1, # 4
+    rxode2::rxGetControl(.ui, "opt_inds", FALSE)*1 #5
+    )
+}
+
 .popedCreateSeparateSamplingDatabase <- function(ui, data, .ctl, .err) {
   .a <- rxode2::rxGetControl(ui, "a", list())
   # Get the observation data
@@ -1886,6 +1897,7 @@ rxUiGet.popedSettings <- function(x, ...) {
                                          G_xt=.env$G_xt,
                                          a=.a,
                                          discrete_xt=.poped$discrete_xt,
+                                         optsw=ui$popedOptsw,
                                          discrete_a=.poped$discrete_a## ,
                                          ## G_xt=.poped$G_xt
                                          )
@@ -2119,6 +2131,7 @@ rxUiGet.popedSettings <- function(x, ...) {
                                            bUseGrouped_xt=rxode2::rxGetControl(ui, "bUseGrouped_xt", FALSE),
                                            discrete_xt=.poped$discrete_xt,
                                            discrete_a=.poped$discrete_a,
+                                           optsw=.ui$popedOptsw,
                                            G_xt=.poped$G_xt)
 
     } else {
@@ -2608,6 +2621,10 @@ popedControl <- function(stickyRecalcN=4,
                          script=NULL,
                          overwrite=TRUE,
                          literalFix=TRUE,
+                         opt_xt=FALSE,
+                         opt_a=FALSE,
+                         opt_x=FALSE,
+                         opt_samps=FALSE,
                          ...) {
   rxode2::rxReq("PopED")
   .xtra <- list(...)
@@ -2809,6 +2826,10 @@ popedControl <- function(stickyRecalcN=4,
   checkmate::assertLogical(bParallelSG, any.missing=FALSE, len=1)
   checkmate::assertLogical(bParallelMFEA, any.missing=FALSE, len=1)
   checkmate::assertLogical(bParallelLS, any.missing=FALSE, len=1)
+  checkmate::assertLogical(opt_xt, any.missing=FALSE, len=1)
+  checkmate::assertLogical(opt_a, any.missing=FALSE, len=1)
+  checkmate::assertLogical(opt_x, any.missing=FALSE, len=1)
+  checkmate::assertLogical(opt_samps, any.missing=FALSE, len=1)
   if (is.null(script)) {
   } else if (checkmate::testLogical(script, len=1, any.missing=FALSE)) {
     if (!script) {
@@ -2943,7 +2964,11 @@ popedControl <- function(stickyRecalcN=4,
                minxt=minxt,
                maxxt=maxxt,
                discrete_xt=discrete_xt,
-               discrete_a=discrete_a)
+               discrete_a=discrete_a,
+               opt_xt=opt_xt,
+               opt_a=opt_a,
+               opt_x=opt_x,
+               opt_samps=opt_samps)
   class(.ret) <- "popedControl"
   .ret
 }

inst/poped/ex.3.a.PKPD.1.comp.oral.md.imax.D-opt.babelmixr2.R

@@ -78,7 +78,6 @@ babel.db <- nlmixr2(f, e, "poped",
                       ourzero=0
                     ))
 
-
 ##  create plot of model and design
 plot_model_prediction(babel.db,facet_scales="free")
 

inst/poped/ex.8.tmdd_qss_one_target_compiled.babelmixr2.R

@@ -96,7 +96,30 @@ db <- nlmixr2(f, e, "poped",
                        c(ID=2, DOSE=600, SC_FLAG=0),
                        c(ID=2, DOSE=1000, SC_FLAG=1)),
                 discrete_a = list(DOSE=seq(100,1000,by=100),
-                                  SC_FLAG=c(0,1))))
+                                  SC_FLAG=c(0,1)),
+              ))
+
+tic();e2 <- evaluate_design(db);toc()
+
+# Currently if you are optimizing times, you need to specify that in
+# the popedControl otherwise it may not work as expected.
+db <- nlmixr2(f, e, "poped",
+              control=popedControl(
+                groupsize=rbind(6,6,6,6,100,100),
+                a=list(c(ID=1, DOSE=100, SC_FLAG=0),
+                       c(ID=1, DOSE=300, SC_FLAG=0),
+                       c(ID=1, DOSE=600, SC_FLAG=0),
+                       c(ID=1, DOSE=1000, SC_FLAG=1),
+                       c(ID=2, DOSE=600, SC_FLAG=0),
+                       c(ID=2, DOSE=1000, SC_FLAG=1)),
+                discrete_a = list(DOSE=seq(100,1000,by=100),
+                                  SC_FLAG=c(0,1)),
+                opt_xt=TRUE
+              ))
+
+# This takes a bit longer because it checks to see if times have
+# changed before solving
+tic();e2 <- evaluate_design(db);toc()
 
 
 plot_model_prediction(db, model_num_points=300, PI=TRUE, facet_scales="free")