R/piping-model.R

Defines functions .addVariableToIniDf rxSetCovariateNamesForPiping rxSetPipingAuto .removeVariableFromIniDf .getAddedOrRemovedVariablesFromNonErrorLines rxUiGet.errParams .getVariablesFromExpression .modifyModelLines .changeDropNullLine .isDropNullType .getAdditionalDropLines .isDropExpression rxUiGet.mvFromExpression .getModelLineFromExpression .getNegativeModelLineForDiffFromProperty .getModelineFromExpressionsAndOriginalLines .getModelLineEquivalentLhsExpression .getModelLineEquivalentLhsExpressionDropDdt .getModelLineEquivalentLhsExpressionDropEndpoint .getRhs .getLhs .isIniDropExpression .isTildeExpr .isAssignment .isEndpoint .modelHandleModelLines model.rxode2 model.rxUi model.function

Documented in model.function .modelHandleModelLines model.rxode2 model.rxUi rxSetCovariateNamesForPiping rxSetPipingAuto

#' @export
#' @rdname model
model.function <- function(x, ..., append=NULL, auto=getOption("rxode2.autoVarPiping", TRUE),
                           cov=NULL, envir=parent.frame()) {
  .modelLines <- .quoteCallInfoLines(match.call(expand.dots = TRUE)[-(1:2)], envir=envir)
  .ret <- rxUiDecompress(rxode2(x))
  if (length(.modelLines) == 0) return(.ret$modelFun)
  .modelHandleModelLines(.modelLines, .ret, modifyIni=FALSE, append=append, auto=auto,
                         cov=cov, envir=envir)
}

#' @export
#' @rdname model
model.rxUi <- function(x, ..., append=NULL, auto=getOption("rxode2.autoVarPiping", TRUE),
                       cov=NULL, envir=parent.frame()) {
  .modelLines <- .quoteCallInfoLines(match.call(expand.dots = TRUE)[-(1:2)], envir=envir)
  .ret <- rxUiDecompress(.copyUi(x)) # copy so (as expected) old UI isn't affected by the call
  if (length(.modelLines) == 0) return(.ret$modelFun)
  .ret <- .modelHandleModelLines(.modelLines, .ret, modifyIni=FALSE, append=append, auto=auto,
                                 cov=cov, envir=envir)
  # need to adjust since the model function was from a rxui object
  .x <- rxUiDecompress(x)
  .ret <- rxUiDecompress(.ret)
  .ret <- .newModelAdjust(.ret, .x)
  .ret <- rxUiCompress(.ret)
  .cls <- setdiff(class(x), class(.ret))
  if (length(.cls) > 0) {
    class(.ret) <- c(.cls, class(.ret))
  }
  .ret
}

#' @export
#' @rdname model
model.rxode2 <- function(x, ..., append=NULL, auto=getOption("rxode2.autoVarPiping", TRUE),
                         cov=NULL, envir=parent.frame()) {
  .modelLines <- .quoteCallInfoLines(match.call(expand.dots = TRUE)[-(1:2)], envir=envir)
  x <- as.function(x)
  .ret <- suppressMessages(rxUiDecompress(rxode2(x)))
  if (length(.modelLines) == 0) return(.ret$modelFun)
  .modelHandleModelLines(.modelLines, .ret, modifyIni=FALSE, append=append, auto=auto,
                         cov=cov, envir=envir)
}

#' @export
#' @rdname model
model.rxModelVars <- model.rxode2

#'  Handle model lines
#'
#' @param modelLines The model lines that are being considered
#' @param rxui The rxode2 UI object
#' @param modifyIni Should the ini({}) be considered
#' @param envir Environment for evaluation
#' @inheritParams model
#' @return New UI
#' @author Matthew L. Fidler
#' @export
.modelHandleModelLines <- function(modelLines, rxui, modifyIni=FALSE, append=NULL,
                                   auto=getOption("rxode2.autoVarPiping", TRUE),
                                   cov=NULL, envir) {
  checkmate::assertLogical(modifyIni, any.missing=FALSE, len=1)
  ## checkmate::assertLogical(append, any.missing=TRUE, len=1)
  checkmate::assertLogical(auto, any.missing=TRUE, len=1)
  checkmate::assertCharacter(cov, pattern="^[.]*[a-zA-Z]+[a-zA-Z0-9._]*$", null.ok=TRUE)
  .varSelect$cov <- cov
  .doAppend <- FALSE
  rxui <- rxUiDecompress(rxui)
  .ll <- length(rxui$lstExpr)
  if (!is.null(.nsEnv$.quoteCallInfoLinesAppend)) {
    if (identical(.nsEnv$.quoteCallInfoLinesAppend, quote(Inf))) {
      .nsEnv$.quoteCallInfoLinesAppend <- NULL
      append <- TRUE
    } else if (identical(.nsEnv$.quoteCallInfoLinesAppend, quote(-Inf))) {
      .nsEnv$.quoteCallInfoLinesAppend <- NULL
      append <- NA
    } else if (identical(.nsEnv$.quoteCallInfoLinesAppend, quote(0))) {
      .nsEnv$.quoteCallInfoLinesAppend <- NULL
      append <- NA
    } else if (checkmate::testIntegerish(.nsEnv$.quoteCallInfoLinesAppend, lower=.ll)) {
      .nsEnv$.quoteCallInfoLinesAppend <- NULL
      append <- TRUE
    }
  }
  if (!is.null(.nsEnv$.quoteCallInfoLinesAppend)) {
    if (checkmate::testIntegerish(.nsEnv$.quoteCallInfoLinesAppend, lower=0, upper=.ll)) {
      .nsEnv$.quoteCallInfoLinesAppend <- .getLhs(rxui$lstExpr[[.nsEnv$.quoteCallInfoLinesAppend]])
    } else if (checkmate::testCharacter(.nsEnv$.quoteCallInfoLinesAppend, len=1, any.missing=FALSE,
                                        min.chars = 1)) {
      .tmp <- try(str2lang(.nsEnv$.quoteCallInfoLinesAppend), silent=TRUE)
      if (inherits(.tmp, "try-error")) {
        stop("'append' must refer to a LHS model line when a character",
             call. = FALSE)
      }
      .nsEnv$.quoteCallInfoLinesAppend <- .tmp
    }
    .w <- which(vapply(seq_len(.ll),
                       function(i) {
                         .lhs <- .getLhs(rxui$lstExpr[[i]])
                         identical(.lhs, .nsEnv$.quoteCallInfoLinesAppend)
                       }, logical(1), USE.NAMES=FALSE))
    if (length(.w) == 0) {
      .var <- deparse1(.nsEnv$.quoteCallInfoLinesAppend)
      .stop <- TRUE
      if (!is.null(.asFunctionEnv$rx)) {
        if (any(.asFunctionEnv$rx$lhs == .var)) {
          .iniDf <- rxui$iniDf
          .tmp <- .asFunctionEnv$rx
          .cls <- class(.asFunctionEnv$rx)
          class(.asFunctionEnv$rx) <- "rxode2"
          .fun <- suppressMessages(as.function(.asFunctionEnv$rx))
          class(.asFunctionEnv$rx) <- .cls
          rxui <- suppressMessages(as.rxUi(.fun))
          ini(rxui) <- .iniDf
          rxui <- rxUiDecompress(rxui)
          .ll <- length(rxui$lstExpr)
          .w <- which(vapply(seq_len(.ll),
                             function(i) {
                               .lhs <- .getLhs(rxui$lstExpr[[i]])
                               identical(.lhs, .nsEnv$.quoteCallInfoLinesAppend)
                             }, logical(1), USE.NAMES=FALSE))
          if (length(.w) == 0) {
            .stop <- TRUE
          } else {
            .stop <- FALSE
          }
        }
      }
      if (.stop) {
        stop("cannot find '", .var, "' in lhs model, cannot append", call.=FALSE)
      }
    }
    .w <- max(.w)
    if (.w == .ll) {
      assign("lstExpr", c(rxui$lstExpr, modelLines), envir=rxui)
    } else {
      assign("lstExpr", c(rxui$lstExpr[seq(1, .w)], modelLines, rxui$lstExpr[seq(.w+1, .ll)]),
             envir=rxui)
    }
    .doAppend <- TRUE
  } else if (is.logical(append) && length(append) == 1L && (is.na(append) || !append)) {
    assign("lstExpr", c(modelLines, rxui$lstExpr), envir=rxui)
    .doAppend <- TRUE
  } else if (isTRUE(append)) {
    assign("lstExpr", c(rxui$lstExpr, modelLines), envir=rxui)
    .doAppend <- TRUE
  }
  if (.doAppend) {
    # in pre-pending or appending, lines are only added
    .lhs <- character(0)
    .rhs <- character(0)
    .lhs0 <- c(rxui$mv0$lhs, rxui$mv0$state, rxui$allCovs, rxui$iniDf$name)
    for (x in modelLines) {
      .isTilde <- .isEndpoint(x)
      if (.isTilde || .isAssignment(x)) {
        .rhs <- unique(c(.getVariablesFromExpression(.getRhs(x), ignorePipe=.isTilde), .rhs))
        .lhs <- unique(c(.getVariablesFromExpression(.getLhs(x)), .lhs))
      }
      .rhs <- setdiff(.rhs, c(.lhs, .lhs0))
      if (isTRUE(auto)) {
        for (v in .rhs) {
          .isCov <- grepl(.varSelect$covariateExceptions, tolower(v))
          .isTheta <- !.isCov && grepl(.varSelect$thetaModelReg, v)
          .isEta <- !.isCov && grepl(.varSelect$etaModelReg, v)
          if (.isTilde || .isTheta || .isEta) {
            .addVariableToIniDf(v, rxui,
                                promote=ifelse(.isTilde,NA,
                                               TRUE))
            .lhs <- c(.lhs, v)
          }
        }
      }
    }
    return(rxUiCompress(rxui$fun()))
  }
  .modifyModelLines(lines = modelLines, rxui = rxui, modifyIni = modifyIni, envir = envir)
  .v <- .getAddedOrRemovedVariablesFromNonErrorLines(rxui)
  if (length(.v$rm) > 0) {
    lapply(.v$rm, function(x) {
      .removeVariableFromIniDf(x, rxui, promote=ifelse(x %in% .v$err, NA, FALSE))
    })
  }
  if (length(.v$new) > 0) {
    lapply(.v$new, function(x) {
      .isErr <- x %in% .v$err
      if (auto || .isErr) {
        .addVariableToIniDf(x, rxui, promote=ifelse(.isErr, NA, FALSE))
      } else if (isTRUE(getOption("rxode2.verbose.pipe", TRUE))) {
        .minfo(paste0("add covariate {.code ", x, "}"))
      }
    })
  }
  rxUiCompress(rxui$fun())
}

# Determine if the input is an endpoint by being 3 long and the call part being
# a tilde
.isEndpoint <- function(expr) {
  .matchesLangTemplate(expr, str2lang(". ~ ."))
}

# Determine if the input is an assignment by being 3 long and the call part
# being either the left arrow, right arrow, or equal sign
.isAssignment <- function(expr) {
  .matchesLangTemplate(expr, str2lang(". <- .")) ||
    .matchesLangTemplate(expr, str2lang(". = ."))
}

.isTildeExpr <- function(expr) {
  .matchesLangTemplate(expr, str2lang("~ ."))
}

.isIniDropExpression <- function(expr) {
  .matchesLangTemplate(expr, str2lang("- ."))
}

# get the left hand side of an assignment or endpoint; returns NULL if the input
# is not an assignment or endpoint
.getLhs <- function(expr) {
  ret <- NULL
  if (.isAssignment(expr) || .isEndpoint(expr)) {
    ret <- expr[[2]]
  }
  ret
}

.getRhs <- function(expr, ignorePipe=FALSE) {
  ret <- NULL
  if (.isAssignment(expr) || .isEndpoint(expr)) {
    ret <- expr[[3]]
  }
  ret
}

.getModelLineEquivalentLhsExpressionDropEndpoint <- function(expr) {
  ret <- NULL
  if (.isEndpoint(expr)) {
    lhs <- .getLhs(expr)
    if (.matchesLangTemplate(lhs, str2lang("-.")) ||
          .matchesLangTemplate(lhs, str2lang(". <- NULL"))) {
      # If it is a drop expression with a minus sign, grab the non-minus part
      ret <- lhs[[2]]
    }
  }
  ret
}

.getModelLineEquivalentLhsExpressionDropDdt <- function(expr) {
  .expr3 <- NULL
  if (.matchesLangTemplate(x = expr, template = str2lang("-d/dt(.name)")) ||
        .matchesLangTemplate(x = expr, template = str2lang("d/dt(.name) <- NULL"))) {
    .expr3 <- expr
    # remove the minus sign from the numerator
    .expr3[[2]] <- .expr3[[2]][[2]]
  }
  .expr3
}

#' This gives a equivalent left handed expression
#'
#' @param expr This exchanges expressions ie f() to F()
#' @return NULL if there isn't an equivalent expression, or the
#'   equivalent expression.
#' @author Matthew L. Fidler
#' @noRd
.getModelLineEquivalentLhsExpression <- function(expr) {
  .expr3 <- .getModelLineEquivalentLhsExpressionDropDdt(expr)
  if (is.null(.expr3)) .expr3 <- .getModelLineEquivalentLhsExpressionDropEndpoint(expr)
  if (length(expr) == 2L) {
    .expr1 <- expr[[1]]
    .expr2 <- expr[[2]]
    if (identical(.expr1, quote(`f`))) {
      .expr3 <- eval(parse(text=paste0("quote(F(",as.character(.expr2),"))")))
    }
    if (identical(.expr1, quote(`F`))) {
      .expr3 <- eval(parse(text=paste0("quote(f(",as.character(.expr2),"))")))
    }
    if (identical(.expr1, quote(`lag`))) {
      .expr3 <- eval(parse(text=paste0("quote(alag(",as.character(.expr2),"))")))
    }
    if (identical(.expr1, quote(`alag`))) {
      .expr3 <- eval(parse(text=paste0("quote(lag(",as.character(.expr2),"))")))
    }
    if (identical(.expr1, quote(`-`))) {
      .expr3 <- .expr2
    }
  }
 .expr3
}

#' Get the model line number from the expression
#'
#' @param expr The Left handed expression to find
#' @param altExpr The alternate expression to find (or `NULL`), this
#'   is for expressions that are equivalent like `f(center)` and
#'   `F(center)`.
#' @param useErrorLine This is a boolean indicating if error lines
#'   should be considered (`TRUE`).
#' @param errLines This is an integer vector of the lines where an
#'   error is defined in the model.
#' @param origLines This is a list of lines in the `model({})` block
#'   of the equation.
#' @param rxui the UI model
#' @param returnAllLines Return all line numbers for the lhs, even
#'   when there are duplicates. (default `FALSE`)
#' @return For duplicated lines: `NULL` for duplicated lines (when
#'   `returnAllLines` is FALSE) or all the line numbers (when
#'   `returnAllLines` is TRUE).
#'
#' For non-duplicated lines return  the line number (if
#'   it is found) and `NA` if it is not found.
#'
#' @author Matthew L. Fidler
#' @noRd
.getModelineFromExpressionsAndOriginalLines <- function(expr, altExpr, useErrorLine,
                                                        errLines, origLines, rxui,
                                                        returnAllLines=FALSE) {
  .ret <- NA_integer_
  .multipleEndpointModel <- length(errLines) != 1L
  for (.i in seq_along(origLines)) {
    .isErrorLine <- .i %in% errLines
    if (returnAllLines ||
          (useErrorLine && .isErrorLine) ||
          (!useErrorLine && !.isErrorLine)) {
      .expr <- origLines[[.i]]
      if (identical(.expr[[2]], expr)) {
        if (is.na(.ret)) {
          .ret <- .i
        } else if (returnAllLines) {
          .ret <- c(.ret, .i)
        } else {
          return(NULL)
        }
      } else if (!is.null(altExpr)) {
        if (identical(.expr[[2]], altExpr)) {
          if (is.na(.ret)) {
            .ret <- .i
          } else if (returnAllLines) {
            .ret <- c(.ret, .i)
          } else {
            return(NULL)
          }
        }
      } else if (useErrorLine  && !.multipleEndpointModel) {
        if (is.na(.ret)) {
          if (.isNormOrTErrorExpression(.expr)) {
            # Make sure the lhs is included in the model prediction
            .var <- deparse1(expr)
            .modelVars <- c(rxui$mv0$lhs, rxui$mv0$state)
            if (!(.var %in% .modelVars)) {
              stop("the variable '", .var, "' must be in the defined the model for piping this: '",deparse(.expr), "'",
                   call.=FALSE)
            }
          }
          if (!identical(.expr[[2]], expr)) {
            warning("with single endpoint model prediction '", deparse1(.expr[[2]]), "' is changed to '", expr, "'",
                    call.=FALSE)
          }
          .ret <- .i
        } else {
          return(NULL)
        }
      }
    }
  }
  .ret
}
#' Get the negative model line for ode based on ode property
#'
#' @param expr Left handed expression
#' @param origLines List of original lines (expressions)
#' @param errorLine Consider error lines
#' @return `NA` if the ODE isn't found. Negative number for the lowest
#'   line of the ODE compartment.
#' @author Matthew L. Fidler
#' @noRd
.getNegativeModelLineForDiffFromProperty <- function(expr, origLines, errorLine) {
  .ret <- NA_integer_
  if (!errorLine && length(expr) == 2L) {
    .expr1 <- expr[[1]]
    .expr2 <- expr[[2]]
    if (is.numeric(.expr2)) {
      .state <- as.character(.expr1)
    } else {
      .state <- as.character(.expr2)
    }
    if (is.numeric(.expr2) ||
          identical(.expr1, quote(`f`)) ||
          identical(.expr1, quote(`F`)) ||
          identical(.expr1, quote(`alag`)) ||
          identical(.expr1, quote(`lag`)) ||
          identical(.expr1, quote(`rate`)) ||
          identical(.expr1, quote(`dur`))) {
      .expr3 <- eval(parse(text=paste0("quote(d/dt(",.state,"))")))
      for (.i in seq_along(origLines)) {
        .expr <- origLines[[.i]]
        if (identical(.expr[[2]], .expr3)) {
          if (is.na(.ret)) {
            .ret <- -.i
          } else {
            .ret <- min(-.i, .ret)
          }
        }
      }
    }
  }
  .ret
}

#' Find the line of the original expression
#'
#' @param expr Expression
#'
#' @param rxui rxode2 UI
#'
#' @param errorLine When TRUE, Should the error line be considered, or
#'   consider the non-error line
#'
#' @param returnAllLines A boolean to determine if all line numbers
#'   should be returned, by default `FALSE`
#'
#' @return The return can be:
#'
#'  - Line number of from the original model, if the model matches one
#'  line uniquely (or an integer vector of all the lines matching when `returnAllLines=TRUE`)
#'
#'  - Negative number; This indicates the model property (ie
#'  `f(depot)`) is not found in the model, but the differential
#'  equation `d/dt(depot)` is defined uniquely i the model and is
#'  found at the -(line number) returned.
#'
#'  - `NA` which means the line (or related line) was not found in the
#'  model
#'
#'  - `NULL` which means a line is duplicated in the model
#'
#' @author Matthew L. Fidler
#'
#' @noRd
.getModelLineFromExpression <- function(lhsExpr, rxui, errorLine=FALSE, returnAllLines=FALSE) {
  .origLines <- rxui$lstExpr
  .errLines <- rxui$predDf$line
  .expr3 <- .getModelLineEquivalentLhsExpression(lhsExpr)
  .ret <- .getModelineFromExpressionsAndOriginalLines(lhsExpr, .expr3, errorLine, .errLines, .origLines, rxui, returnAllLines)
  if (is.null(.ret)) {
    return(NULL)
  } else if (length(.ret) > 1) {
    return(.ret)
  } else if (!is.na(.ret)) {
    return(.ret)
  }
  .getNegativeModelLineForDiffFromProperty(lhsExpr, .origLines, errorLine)
}


#' @export
rxUiGet.mvFromExpression <- function(x, ...) {
  .x <- x[[1]]
  .exact <- x[[2]]
  if (is.null(.x$predDf)) {
    eval(call("rxModelVars",as.call(c(list(quote(`{`)), .x$lstExpr))))
  } else {
    eval(call("rxModelVars",as.call(c(list(quote(`{`)), .x$lstExpr[-.x$predDf$line]))))
  }
}
attr(rxUiGet.mvFromExpression, "desc") <- "Calculate model variables from stored (possibly changed) expression"

#' Describe if the piping expression is a drop expression
#'
#' @param line expression for line/expression
#' @return `TRUE` if this is a drop expression like `%>% model(-v)`, otherwise `FALSE`
#' @author Matthew L. Fidler
#' @noRd
.isDropExpression <- function(line) {
  if (!is.null(.getModelLineEquivalentLhsExpressionDropDdt(line))) {
    return(TRUE)
  }
  if (!is.null(.getModelLineEquivalentLhsExpressionDropEndpoint(line))) {
    return(TRUE)
  }
  if (length(line) == 2L) {
    if (identical(line[[1]], quote(`-`))) {
      if (is.name(line[[2]])) {
        return(TRUE)
      } else if (is.call(line[[2]]) && length(line[[2]]) == 2L) {
        if (is.name(line[[2]][[2]]) &&
              as.character(line[[2]][[1]]) %in% c("F", "f", "alag", "lag", "dur", "rate")) {
          return(TRUE)
        } else if (identical(line[[2]][[2]], 0)) {
          return(TRUE)
        }
      }
    }
  }
  FALSE
}

.getAdditionalDropLines <- function(line, rxui, isErr, isDrop) {
  .dropCmt <- .getModelLineEquivalentLhsExpressionDropDdt(line)
  if (!is.null(.dropCmt)) {
    .state <- .dropCmt[[3]][[2]]
    .types <- list(quote(`f`), quote(`F`), quote(`alag`),
                   quote(`lag`), quote(`dur`), quote(`rate`), NULL)
    .types <- lapply(seq_along(.types),
                     function(i) {
                       .cur <- .types[[i]]
                       if (is.null(.cur)) {
                         as.call(list(.state, 0))
                       } else {
                         as.call(list(.cur, .state))
                       }
                     })
    return(unique(do.call("c", lapply(seq_along(.types), function(i) {
      .v <- .getModelLineFromExpression(.types[[i]], rxui, isErr, isDrop)
      if (is.na(.v[1])) {
        return(NULL)
      } else if (.v[1] < 0) {
        return(NULL)
      } else {
        return(.v)
      }
    }))))
  }
  NULL
}
#' This checks the different types of drop assignments
#'
#'
#' @param prefix The prefix of the drop assignment
#' @param line The line expression to check
#' @return logical to say if this matches the prefix
#' @author Matthew L. Fidler
#' @noRd
.isDropNullType <- function(prefix, line) {
  .e1 <- str2lang(paste0(prefix, " <- NULL"))
  .e2 <- str2lang(paste0(prefix, " = NULL"))
  .e3 <- str2lang(paste0(prefix, " ~ NULL"))
  if (.matchesLangTemplate(line, .e1)) return(TRUE)
  if (.matchesLangTemplate(line, .e3)) return(TRUE)
  if (.matchesLangTemplate(line, .e2)) return(TRUE)
  FALSE
}
#' This changes NULL assignment line to a -drop line
#'
#' @param line Line to change if necessary
#' @return Drop line normalized to be `-line` instead of  `line <- NULL`
#' @author Matthew L. Fidler
#' @noRd
.changeDropNullLine <- function(line) {
  if (.isDropNullType("d/dt(.name)", line)) {
    .ret <- line[[2]]
    .ret[[2]] <- as.call(list(quote(`-`), .ret[[2]]))
    return(.ret)
  }
  if (.isDropNullType(".name", line) ||
        .isDropNullType("lag(.name)", line) ||
        .isDropNullType("alag(.name)", line) ||
        .isDropNullType("f(.name)", line) ||
        .isDropNullType("F(.name)", line) ||
        .isDropNullType("rate(.name)", line) ||
        .isDropNullType("dur(.name)", line) ||
        .isDropNullType(".name(0)", line)
        ) {
    return(as.call(list(quote(`-`), line[[2]])))
  }
  line
}

#'  Modify the error lines/expression
#'
#' @param lines quoted lines to modify
#' @param rxui UI to save information
#' @param modifyIni Modify ini({}) types of calls
#' @param envir Environment
#' @return Nothing, called for the side effects
#' @author Matthew L. Fidler
#' @noRd
.modifyModelLines <- function(lines, rxui, modifyIni=FALSE, envir) {
  .err <- NULL
  .env <- environment()
  lapply(lines, function(line) {
    line <- .changeDropNullLine(line)
    if (modifyIni && .isQuotedLineRhsModifiesEstimates(line, rxui)) {
      .iniHandleFixOrUnfix(line, rxui, envir=envir)
    } else {
      .isErr  <- .isErrorExpression(line)
      .isDrop <- .isDropExpression(line)
      if (.isDrop && .isErr) {
        .ret <- .getModelLineFromExpression(.getModelLineEquivalentLhsExpression(line), rxui, .isErr, FALSE)
      } else if (.isDrop) {
        .ret <- .getModelLineFromExpression(.getModelLineEquivalentLhsExpression(line), rxui, .isErr, .isDrop)
        .ret <- c(.ret, .getAdditionalDropLines(line, rxui, .isErr, .isDrop))
      } else {
        .ret <- .getModelLineFromExpression(.getLhs(line), rxui, .isErr, .isDrop)
      }
      if (length(.ret)  == 1) {
        if (.isErr && is.na(.ret)) {
          stop("the error '", deparse1(line[[2]]), "' is not in the multiple-endpoint model and cannot be modified",
               call.=FALSE)
        }
      }
      if (is.null(.ret)) {
        assign(".err",
               c(.err, paste0("the lhs expression '", deparse1(line[[2]]), "' is duplicated in the model and cannot be modified by piping")),
               envir=.env)
      } else if (is.na(.ret[1])) {
          assign(".err",
                 c(.err, paste0("the lhs expression '", deparse1(line[[2]]), "' is not in the model and cannot be modified by piping")),
                 envir=.env)
      } else if (all(.ret > 0)) {
        if (.isDrop) {
          .lstExpr <- get("lstExpr", rxui)
          .predDf <- get("predDf", rxui)
          .ret0 <- sort(.ret, decreasing=TRUE)
          if (length(.predDf$cond) == 1L && any(.ret0 %in% .predDf$line)) {
            .predDf <- NULL
            .lstExpr <- .lstExpr[-.ret]
          } else {
            for (.i in .ret0) {
              ## Drop lines that match
              .w <- which(.predDf$line == .i)
              if (length(.w) > 0) {
                .predDf <- .predDf[-.w,, drop = FALSE]
              }
              # renumber lines greater
              .w <- which(.predDf$line > .i)
              if (length(.w) > 0) {
                .predDf$line[.w] <- .predDf$line[.w] - 1L
              }
              .lstExpr <- .lstExpr[-.i]
            }
          }
          assign("predDf", .predDf, rxui)
          assign("lstExpr", .lstExpr, rxui)
          assign(".recalculate", TRUE, rxui)
        } else {
          if (.isErr) {
            .throwIfInvalidTilde(line)
          }
          .lstExpr <- get("lstExpr", rxui)
          .lstExpr[[.ret]] <- line
          assign("lstExpr", .lstExpr, rxui)
          assign(".recalculate", TRUE, rxui)
        }
      } else {
        if (.isErr) {
          .throwIfInvalidTilde(line)
        }
        .lstExpr <- get("lstExpr", rxui)
        .lstExpr[[length(.lstExpr) + 1]] <- line
        assign("lstExpr", .lstExpr, rxui)
        assign(".recalculate", TRUE, rxui)
      }
    }
    NULL
  })
  if (!is.null(.err)) {
    stop(paste(.err, collapse="\n"), call.=FALSE)
  }
}

#' Get the Variables from the expression
#'
#' @param x Expression
#' @return Character vector of variables
#' @author Matthew L. Fidler
#' @noRd
.getVariablesFromExpression <- function(x, ignorePipe=FALSE) {
  if (is.atomic(x)) {
    character()
  } else if (is.name(x)) {
    return(as.character(x))
  } else if (.matchesLangTemplate(x, str2lang("d/dt(.name)"))) {
    # ODE expressions only pull out the state name and not "d" or "dt"
    return(as.character(x[[3]][[2]]))
  } else {
    if (is.call(x)) {
      if (ignorePipe && identical(x[[1]], quote(`|`))) {
        return(.getVariablesFromExpression(x[[2]]))
      } else {
        x1 <- x[-1]
      }
    } else {
      x1 <- x
    }
    unique(unlist(lapply(x1, .getVariablesFromExpression, ignorePipe=ignorePipe)))
  }
}

#' @export
rxUiGet.errParams <- function(x, ...) {
  .x <- x[[1]]
  .exact <- x[[2]]
  unlist(lapply(.x$lstExpr[.x$predDf$line], function(x) {
    .getVariablesFromExpression(x[[3]])
  }))
}
attr(rxUiGet.errParams, "desc") <- "Get the error-associated variables"

#' Get the added or removed variables
#'
#' @param rxui This is the rxode2 UI object
#'
#' @return A list with the removed and added error objects
#'
#' @author Matthew L. Fidler
#'
#' @noRd
.getAddedOrRemovedVariablesFromNonErrorLines <- function(rxui) {
  .old <- rxui$mv0$params
  .new <- rxui$mvFromExpression$params
  .both <- intersect(.old, .new)
  .rm1 <- setdiff(.old, .both)
  .new1 <- setdiff(.new, .both)

  .old <- rxui$errParams0
  .err <- rxui$errParams
  .new <- rxui$errParams
  .both <- intersect(.old, .new)
  .rm2 <- setdiff(.old, .both)
  .new2 <- setdiff(.new, .both)

  .new <- c(.new1, .new2)
  .new <- setdiff(.new, rxui$mv0$lhs)

  .rm <- c(.rm1, .rm2)

  .rm <- setdiff(.rm, .err)

  list(rm=.rm, new=.new, err=.err)
}

#' Remove a single variable from the initialization data frame
#'
#' @param var Variable that is removed
#' @param rxui UI function where the initial estimate data frame is modified
#' @inheritParams .addVariableToIniDf
#' @return Nothing, called for side effects
#' @author Matthew L. Fidler
#' @noRd
.removeVariableFromIniDf <- function(var, rxui, promote=FALSE) {
  .iniDf <- rxui$iniDf
  .w <- which(.iniDf$name == var)
  if (length(.w) == 1L) {
    .neta <- .iniDf$neta1[.w]
    .iniDf <- .iniDf[-.w, ]
    if (!is.na(.neta)) {
      # Here we remove any assocaited covariance terms that remain
      .w1 <- which(.iniDf$neta1 == .neta)
      if (length(.w1) > 0) .iniDf <- .iniDf[-.w1, ]
      .w1 <- which(.iniDf$neta2 == .neta)
      if (length(.w1) > 0) .iniDf <- .iniDf[-.w1, ]
      if (isTRUE(getOption("rxode2.verbose.pipe", TRUE))) {
        .mwarn(paste0("remove between subject variability {.code ", var, "}"))
      }
    } else if (isTRUE(getOption("rxode2.verbose.pipe", TRUE))) {
      if (is.na(promote)) {
        .mwarn(paste0("remove residual parameter {.code ", var, "}"))
      } else {
        .mwarn(paste0("remove population parameter {.code ", var, "}"))
      }
    }
    assign("iniDf", .iniDf, rxui)
  }
  invisible()
}

.varSelect <- new.env(parent=emptyenv())
#' Set the variables for the model piping automatic covarite selection
#'
#' @param thetamodelVars This is the prefixes for the theta model
#'   variables in a regular expression
#' @param covariateExceptions This is a regular expression of
#'   covariates that should always be covariates
#' @param etaParts This is the list of eta prefixes/post-fixes that
#'   identify a variable as a between subject variability
#' @return Nothing, called for side effects
#' @export
#' @author Matthew L. Fidler
#' @details
#'
#' This is called once at startup to set the defaults, though you can
#' change this if you wish so that piping can work differently for
#' your individual setup
#'
rxSetPipingAuto <- function(thetamodelVars=rex::rex(or("tv", "t", "pop", "POP", "Pop",
                                                     "TV", "T", "cov", "err", "eff")),
                          covariateExceptions = rex::rex(start, or("wt", "sex", "crcl", "kout"), end),
                          etaParts=c("eta", "ETA", "Eta", "ppv", "PPV", "Ppv", "iiv", "Iiv",
                                     "bsv", "Bsv", "BSV","bpv", "Bpv", "BPV", "psv", "PSV",
                                     "Psv")
                          ) {
  .varSelect$thetamodelVars <- thetamodelVars
  .varSelect$thetaModelReg <- rex::rex(or(
    group(start, thetamodelVars),
    group(thetamodelVars, end)))
  .varSelect$covariateExceptions <- covariateExceptions
  .varSelect$etaParts <- etaParts
  .varSelect$etaModelReg <- rex::rex(or(group(start, or(etaParts)),
                                        group(or(etaParts), end)))
  .varSelect$covariateNames <- NULL
  .varSelect$cov <- NULL
}

rxSetPipingAuto()

.rxIniDfTemplate <-
  data.frame(
    ntheta = NA_integer_,
    neta1 = NA_real_,
    neta2 = NA_real_,
    name = NA_character_,
    lower = -Inf,
    est = NA_real_,
    upper = Inf,
    fix = FALSE,
    label = NA_character_,
    backTransform = NA_character_,
    condition = NA_character_,
    err = NA_character_
  )

#' Assign covariates for piping
#'
#' @param covariates NULL (for no covariates), or the list of
#'   covariates. nlmixr uses this function to set covariates if you
#'   pipe from a nlmixr fit.
#'
#' @return Nothing, called for side effects
#'
#' @author Matthew L. Fidler
#'
#' @export
#'
#' @examples
#'
#' # First set the name of known covariates
#' # Note this is case sensitive
#'
#' rxSetCovariateNamesForPiping(c("WT","HT", "TC"))
#'
#' one.compartment <- function() {
#'  ini({
#'    tka <- 0.45 ; label("Log Ka")
#'    tcl <- 1 ; label("Log Cl")
#'    tv <- 3.45 ; label("Log V")
#'    eta.ka ~ 0.6
#'    eta.cl ~ 0.3
#'    eta.v ~ 0.1
#'    add.err <- 0.7
#'  })
#'  model({
#'    ka <- exp(tka + eta.ka)
#'    cl <- exp(tcl + eta.cl)
#'    v <- exp(tv + eta.v)
#'    d / dt(depot) <- -ka * depot
#'    d/dt(depot) <- -ka * depot
#'    d / dt(center) <- ka * depot - cl / v * center
#'    cp <- center / v
#'    cp ~ add(add.err)
#'  })
#' }
#'
#' # now TC is detected as a covariate instead of a population parameter
#'
#' one.compartment %>%
#'   model({ka <- exp(tka + eta.ka + TC * cov_C)})
#'
#' # You can turn it off by simply adding it back
#'
#' rxSetCovariateNamesForPiping()
#'
#' one.compartment %>%
#'   model({ka <- exp(tka + eta.ka + TC * cov_C)})
#'
#' # The covariates you set with `rxSetCovariateNamesForPiping()`
#' # are turned off every time you solve (or fit in nlmixr)
#'
#' @export
rxSetCovariateNamesForPiping <- function(covariates=NULL) {
  if (!is.null(covariates)) {
    checkmate::assertCharacter(covariates, any.missing=FALSE, unique=TRUE)
  }
  .varSelect$covariateNames <-  covariates
}
#' Add a single variable from the initialization data frame
#'
#' @param var Variable that is added
#' @param rxui UI function where the initial estimate data frame is
#'   modified
#' @param toEta This boolean determines if it should be added to the
#'   etas (`TRUE`), thetas (`FALSE`) or determined by `.etaModelReg`
#'   (`NA`)
#' @param value This is the value to assign to the ini block
#' @param promote This boolean determines if the parameter was
#'   promoted from an initial covariate parameter (`TRUE`).  If so it
#'   changes the verbose message to the user.  If not, (`FALSE`) it
#'   will only add if it is a covariate.  If `NA` it will assume that
#'   the parameter is an error term. When `promote` is `TRUE`, it will
#'   also remove the parameter from the `$allCovs`.
#' @return Nothing, called for side effects
#' @author Matthew L. Fidler
#' @noRd
.addVariableToIniDf <- function(var, rxui, toEta=NA, value=1, promote=FALSE) {
  if (var %in% c("pi", "M_E", "M_E", "E", "M_PI", "M_PI_2",
                 "M_PI_4", "M_1_PI", "M_2_PI", "M_2PI", "M_SQRT_PI",
                 "M_2_SQRTPI", "M_1_SQRT_2PI", "M_SQRT2", "M_SQRT_3",
                 "M_SQRT_32", "M_SQRT_2dPI", "M_LN_SQRT_PI",
                 "M_LN_SQRT_2PI", "M_LN_SQRT_PId2", "M_LOG10_2",
                 "M_LOG2E", "M_LOG10E", "M_LN2", "M_LN10")) {
    return(invisible())
  }
  if (!is.null(.varSelect$cov)) {
    if (var %in% .varSelect$cov) {
      if (isTRUE(getOption("rxode2.verbose.pipe", TRUE))) {
        .minfo(paste0("add covariate {.code ", var, "} (as requested by cov option)"))
      }
      return(invisible())
    }
  }
  .mv <- rxModelVars(rxui)
  .ini <- .mv$ini
  .ini <- .ini[which(!is.na(.ini))]
  if (var %in% names(.ini)) {
    return(invisible())
  }
  .iniDf <- rxui$iniDf
  .isEta <- TRUE
  checkmate::assertLogical(toEta, len=1)
  if (is.na(promote)) {
    checkmate::assertNumeric(value, len=1, any.missing=FALSE)
  } else if (promote) {
    if (is.na(toEta)) {
      checkmate::assertNumeric(value, len=1, any.missing=FALSE)
    } else if (toEta) {
      checkmate::assertNumeric(value, len=1, any.missing=TRUE)
    } else {
      if (length(value) %in% c(2, 3)) {
        # This is for promotion to parameter, only.  Additional bound setting
        # happens elsewhere.
        value <- value[2]
      }
      checkmate::assertNumeric(value, len=1, any.missing=FALSE)
    }
  } else {
    checkmate::assertNumeric(value, len=1, any.missing=FALSE)
  }
  checkmate::assertLogical(promote, len=1)
  if (is.na(toEta)) {
    .isEta <- (regexpr(.varSelect$etaModelReg, var)  != -1)
  } else  {
    .isEta <- toEta
  }
  if (.isEta) {
    if (all(is.na(.iniDf$neta1))) {
      .eta <- 1
    } else {
      .eta <- max(.iniDf$neta1, na.rm=TRUE) + 1
    }
    .extra <- .rxIniDfTemplate
    .extra$est <- value
    .extra$neta1 <- .eta
    .extra$neta2 <- .eta
    .extra$name <- var
    .extra$condition <- "id"
    if (isTRUE(getOption("rxode2.verbose.pipe", TRUE))) {
      if (is.na(promote)) {
      } else if (promote) {
        if (is.na(value))  {
          value <- 1
          .minfo(paste0("promote {.code ", var, "} to between subject variability"))
        } else {
          .minfo(paste0("promote {.code ", var, "} to between subject variability with initial estimate {.number ", value, "}"))
        }
        .cov <- get("covariates", envir=rxui)
        .cov <- .cov[.cov != var]
        assign("covariates", .cov, envir=rxui)
      } else {
        .minfo(paste0("add between subject variability {.code ", var, "} and set estimate to {.number ", value, "}"))
      }
    }
    assign("iniDf", rbind(.iniDf, .extra), envir=rxui)
  } else {
    if (is.na(promote)) {
    } else if (!promote) {
      if (regexpr(.varSelect$covariateExceptions, tolower(var)) != -1 ||
            regexpr(.varSelect$thetaModelReg, var, perl=TRUE) == -1) {
        if (isTRUE(getOption("rxode2.verbose.pipe", TRUE))) {
          .minfo(paste0("add covariate {.code ", var, "}"))
        }
        return(invisible())
      }
      if (!is.null(.varSelect$covariateNames)) {
        if (var %in% .varSelect$covariateNames) {
          if (isTRUE(getOption("rxode2.verbose.pipe", TRUE))) {
            .minfo(paste0("add covariate {.code ", var, "} (known covariate)"))
          }
          return(invisible())
        }
      }
    }
    if (all(is.na(.iniDf$ntheta))) {
      .theta <- 1
    } else {
      .theta <- max(.iniDf$ntheta, na.rm=TRUE) + 1
    }
    .extra <- .rxIniDfTemplate
    .extra$est <- value
    .extra$ntheta <- .theta
    .extra$name <- var
    if (isTRUE(getOption("rxode2.verbose.pipe", TRUE))) {
      if (is.na(promote)) {
        .minfo(paste0("add residual parameter {.code ", var, "} and set estimate to {.number ", value, "}"))
      } else if (promote) {
        .minfo(paste0("promote {.code ", var, "} to population parameter with initial estimate {.number ", value, "}"))
        # need to reassess model for mu2 enhancement
        assign("iniDf", rbind(.iniDf, .extra), envir=rxui)
        rxui2 <- rxui
        model(rxui2) <- rxui$lstExpr
        rxui2 <- rxUiDecompress(rxui2)
        for (i in ls(envir=rxui2, all.names=TRUE)) {
          assign(i, get(i, envir=rxui2), envir=rxui)
        }
        return(invisible())
      } else {
        .minfo(paste0("add population parameter {.code ", var, "} and set estimate to {.number ", value, "}"))
      }
    }
    assign("iniDf", rbind(.iniDf, .extra), envir=rxui)
  }
  invisible()
}
nlmixr2/rxode2 documentation built on Jan. 11, 2025, 8:48 a.m.