Ui modification functions

DESCRIPTION

@@ -26,6 +26,7 @@ Authors@R: c(
    person("Matt", "Dowle", role="ctb", email="mattjdowle@gmail.com"),
    person("Matteo", "Fasiolo", email = "matteo.fasiolo@gmail.com", role = "ctb"),
    person("Melissa", "Hallow", role = "aut", email = "hallowkm@uga.edu"),
+   person("Michel", "Lang", , "michellang@gmail.com", role = "ctb"),
    person("Morwenn","", role="ctb"),
    person("Nicholas J.", "Higham",role="ctb"),
    person("Omar", "Elashkar", email="omar.i.elashkar@gmail.com", role="ctb"),

NAMESPACE

@@ -275,6 +275,7 @@ export(.pipeRx)
 export(.pipeSigma)
 export(.pipeThetaMat)
 export(.quoteCallInfoLines)
+export(.rxBlankIni)
 export(.rxC)
 export(.rxDocTable)
 export(.rxFromSE)
@@ -325,6 +326,7 @@ export(assertCompartmentExists)
 export(assertCompartmentName)
 export(assertCompartmentNew)
 export(assertExists)
+export(assertIniDf)
 export(assertParameterValue)
 export(assertRxLinCmt)
 export(assertRxUi)
@@ -385,6 +387,11 @@ export(label_both)
 export(label_context)
 export(label_value)
 export(label_wrap_gen)
+export(linMod)
+export(linMod0)
+export(linModA0)
+export(linModB)
+export(linModB0)
 export(llikBeta)
 export(llikBinom)
 export(llikCauchy)
@@ -466,6 +473,8 @@ export(rxIndLinState)
 export(rxIndLinStrategy)
 export(rxInit)
 export(rxInits)
+export(rxIntToBase)
+export(rxIntToLetter)
 export(rxInv)
 export(rxIs)
 export(rxIsCurrent)
@@ -537,6 +546,9 @@ export(rxTick)
 export(rxToSE)
 export(rxTrans)
 export(rxUdfUi)
+export(rxUdfUiIniDf)
+export(rxUdfUiIniLhs)
+export(rxUdfUiNum)
 export(rxUiCompress)
 export(rxUiDecompress)
 export(rxUiDeparse)
@@ -589,6 +601,7 @@ export(stat_cens)
 export(swapMatListWithCube)
 export(testCompartmentExists)
 export(testExists)
+export(testIniDf)
 export(testRxLinCmt)
 export(testRxUnbounded)
 export(testVariableExists)

R/assert.R

@@ -615,3 +615,34 @@ warnRxBounded <- function(ui, extra="", .var.name=.vname(ui)) {
   }
   invisible()
 }
+
+#' This function tests if this object is a iniDf as needed by the UI
+#'
+#'
+#' @param iniDf the object to test if it is a rxode2 ui `iniDf` data.frame
+#' @inheritParams checkmate::testDataFrame
+#' @return boolean, indicating if the object is a valid initialization data frame
+#' @export
+#' @author Matthew L. Fidler
+#' @examples
+#' testIniDf(TRUE)
+testIniDf <- function(iniDf) {
+  if (checkmate::testDataFrame(iniDf)) {
+    checkmate::testSubset(names(iniDf),
+                          c("ntheta", "neta1", "neta2", "name", "lower", "est", "upper",
+                            "fix", "label", "backTransform", "condition", "err"))
+  } else {
+    FALSE
+  }
+}
+#' @describeIn testIniDf Assert that the object is a valid rxode2 ui initialization data frame
+#' @export
+assertIniDf <- function(iniDf, extra="", .var.name=.vname(iniDf), null.ok = FALSE) {
+  if (testIniDf(iniDf)) {
+    return(invisible(iniDf))
+  }
+  if (null.ok && is.null(iniDf)) {
+    return(invisible(NULL))
+  }
+  stop("'", .var.name, "' is not a rxode2 ui initial conditions data.frame", extra, call.=FALSE)
+}

R/err.R

@@ -1035,6 +1035,74 @@ rxErrTypeCombine <- function(oldErrType, newErrType) {
   }
 }
 
+#' Get a blank, theta1, or eta1 initialization block for iniDf
+#'
+#' @param type type of initialization block to return
+#' @return A data.frame with the appropriate number/type of columns.
+#'
+#' For type="empty", the data.frame will have 0 rows but all the correct types.
+#'
+#' For type="theta", the data.frame will have 1 row with the correct
+#' types and default values.  The "name" and "est" will likely need to
+#' be updated.
+#'
+#' For type="eta", the data.frame will have 1 row with the correct
+#' types and default values for the a single eta being added.  The
+#' "name" and "est" will likely need to be updated.
+#'
+#'
+#' @export
+#' @author Matthew L. Fidler
+#' @keywords internal
+#' @examples
+#'
+#' .rxBlankIni("empty")
+#'
+#' .rxBlankIni("theta")
+#'
+#' .rxBlankIni("eta")
+#'
+.rxBlankIni <- function(type=c("emtpy", "theta", "eta")) {
+  type <- match.arg(type)
+  if (type == "empty") {
+    data.frame(ntheta=integer(0),
+               neta1=integer(0),
+               neta2=integer(0),
+               name=character(0),
+               lower=numeric(0),
+               est=numeric(0),
+               upper=numeric(0),
+               fix=logical(0),
+               err=character(0),
+               label=character(0),
+               stringsAsFactors=FALSE)
+  } else if (type == "theta") {
+    data.frame(ntheta=1L,
+               neta1=NA_integer_,
+               neta2=NA_integer_,
+               name=NA_character_,
+               lower=-Inf,
+               est=0,
+               upper=Inf,
+               fix=FALSE,
+               err=NA_character_,
+               label=NA_character_,
+               stringsAsFactors=FALSE)
+  } else {
+    data.frame(ntheta=NA_integer_,
+               neta1=1L,
+               neta2=1L,
+               name=NA_character_,
+               lower=0,
+               est=0.1,
+               upper=Inf,
+               fix=FALSE,
+               err=NA_character_,
+               label=NA_character_,
+               stringsAsFactors=FALSE)
+  }
+}
+
 #' Process the errors in the quoted expression
 #'
 #' @param x Quoted expression for parsing
@@ -1078,6 +1146,11 @@ rxErrTypeCombine <- function(oldErrType, newErrType) {
 .errProcessExpression <- function(x, ini,
                                   linCmtSens = c("linCmtA", "linCmtB", "linCmtC"),
                                   verbose=FALSE, checkMissing=TRUE) {
+  on.exit({
+    .udfUiEnv$num <- 1L
+    .udfUiEnv$iniDf <- NULL
+    .udfUiEnv$lhs <- NULL
+  })
   # ntheta neta1 neta2   name lower       est   upper   fix  err  label
   # backTransform condition trLow trHi
   .env <- new.env(parent=emptyenv())
@@ -1122,7 +1195,15 @@ rxErrTypeCombine <- function(oldErrType, newErrType) {
           .errHandleTilde(.y[[.i]], .env)
         } else {
           .env$redo <- FALSE
-          .cur <- .handleUdfUi(.y[[.i]], .env)
+          .cur <- .y[[.i]]
+          if (length(.cur) >= 3 && identical(.cur[[1]], quote(`<-`))) {
+            .env$lhs <- .cur[[2]]
+          } else if (length(.cur)>= 3 && identical(.cur[[1]], quote(`=`))) {
+            .env$lhs <- .cur[[2]]
+          } else {
+            .env$lhs <- NULL
+          }
+          .cur <- .handleUdfUi(.cur, .env)
           .len <- length(.y)
           .y <- c(lapply(seq_len(.i - 1),
                          function(i) {
@@ -1244,7 +1325,8 @@ rxErrTypeCombine <- function(oldErrType, newErrType) {
                          "lastDistAssign", "line", "needsToBeAnErrorExpression",
                          "needToDemoteAdditiveExpression",
                          "top", "trLimit", ".numeric", "a", "b", "c", "d", "e", "f",  "lambda",
-                         "curCmt", "errGlobal", "linCmt", "ll", "distribution", "rxUdfUiCount", "before", "after"),
+                         "curCmt", "errGlobal", "linCmt", "ll", "distribution", "rxUdfUiCount", "before", "after",
+                         "lhs"),
                        ls(envir=.env, all.names=TRUE))
       if (length(.rm) > 0) rm(list=.rm, envir=.env)
       if (checkMissing) .checkForMissingOrDupliacteInitials(.env)