R/deparse.R

In nlmixr2est: Nonlinear Mixed Effects Models in Population PK/PD, Estimation Routines

.deparseShared <- function(x, value) {
  if (x == "rxControl") {
    .rx <- rxUiDeparse(value, "a")
    .rx <- .rx[[3]]
    paste0("rxControl = ", deparse1(.rx))
  } else if (x == "scaleType")  {
    if (is.integer(value)) {
      .scaleTypeIdx <- c("norm" = 1L, "nlmixr2" = 2L, "mult" = 3L, "multAdd" = 4L)
      paste0("scaleType =", deparse1(names(.scaleTypeIdx[which(value == .scaleTypeIdx)])))
    } else {
      paste0("scaleType =", deparse1(value))
    }
  } else if (x == "normType") {
    if (is.integer(value)) {
      .normTypeIdx <- c("rescale2" = 1L, "rescale" = 2L, "mean" = 3L, "std" = 4L, "len" = 5L, "constant" = 6L)
      paste0("normType =", deparse1(names(.normTypeIdx[which(value == .normTypeIdx)])))
    } else {
      paste0("normType =", deparse1(value))
    }
  } else if (x == "solveType") {
    if (is.integer(value)) {
      .solveTypeIdx <- c("hessian" = 3L, "grad" = 2L, "fun" = 1L)
      paste0("solveType =", deparse1(names(.solveTypeIdx[which(value == .solveTypeIdx)])))
    } else {
      paste0("normType =", deparse1(value))
    }
  } else if (x == "eventType") {
    if (is.integer(value)) {
      .eventTypeIdx <- c("central" =2L, "forward"=1L, "forward"=3L)
      paste0("eventType = ",
             deparse1(names(.eventTypeIdx[which(value == .eventTypeIdx)])))
    } else {
      paste0("eventType = ",
             deparse1(value))
    }
  } else if (x == "censMethod")  {
    if (is.integer(value)) {
      .censMethodIdx <- c("truncated-normal"=3L, "cdf"=2L, "omit"=1L, "pred"=5L, "ipred"=4L, "epred"=6L)
      paste0("censMethod = ",
             deparse1(names(.censMethodIdx[which(value == .censMethodIdx)])))
    } else {
      paste0("censMethod = ",
             deparse1(value))
    }
  } else {
    NA_character_
  }
}

#' Identify Differences Between Standard and New Objects but used in rxUiDeparse
#'
#' This function compares elements of a standard object with a new
#' object and identifies which elements are different.  It is used to
#' only show values that are different from the default when deparsing
#' control objects.
#'
#' @param standard The standard object used for comparison. (for example `foceiControl()`)
#'
#' @param new The new object to be compared against the standard. This
#'   would be what the user supplide like
#'   `foceiControl(outerOpt="bobyqa")`
#' @param internal A character vector of element names to be ignored
#'   during the comparison. Default is an empty character
#'   vector. These are for internal items of the list that flag
#'   certain properties like if the `rxControl()` was generated by the
#'   `foceiControl()` procedure or not.
#' @return A vector of indices indicating which elements of the
#'   standard object differ from the new object.
#' @examples
#' standard <- list(a = 1, b = 2, c = 3)
#' new <- list(a = 1, b = 3, c = 3)
#' .deparseDifferent(standard, new)
#' @export
#' @keywords internal
#' @author Matthew L. Fidler
.deparseDifferent <- function(standard, new, internal=character(0)) {
  which(vapply(names(standard),
               function(x) {
                 if (x %in% internal){
                   FALSE
                 } else if (is.function(standard[[x]])) {
                   warning(paste0("'", x, "' as a function not supported in ",
                                  class(standard), "() deparsing"), call.=FALSE)
                   FALSE
                 } else {
                   !identical(standard[[x]], new[[x]])
                 }
               }, logical(1), USE.NAMES=FALSE))
}

#' Deparse finalize a control or related object into a language object
#'
#' This function deparses an object into a language expression,
#' optionally using a custom function for specific elements.
#'
#' @param default A default object used for comparison; This is the
#'   estimation control procedure.  It should have a class matching
#'   the function that created it.
#' @param object The object to be deparsed into a language exression
#' @param w A vector of indices indicating which elements are
#'   different and need to be deparsed. This likely comes from
#'   `.deparseDifferent()`
#' @param var A string representing the variable name to be assigned
#'   in the deparsed expression.
#' @param fun An optional custom function to handle specific elements
#'   during deparsing. Default is NULL. This handles things that are
#'   specific to an estimation control and is used by functions like
#'   `rxUiDeparse.saemControl()`
#' @return A language object representing the deparsed expression.
#' @keywords internal
#' @author Matthew L. Fidler
#' @export
.deparseFinal <- function(default, object, w, var, fun=NULL) {
  .cls <- class(object)
  if (length(w) == 0) {
    return(str2lang(paste0(var, " <- ", .cls, "()")))
  }
  .retD <- vapply(names(default)[w], function(x) {
    .val <- .deparseShared(x, object[[x]])
    if (!is.na(.val)) {
      return(.val)
    }
    if (is.function(fun)) {
      .val <- fun(default, x, object[[x]])
      if (!is.na(.val)) {
        return(.val)
      }
    }
    paste0(x, "=", deparse1(object[[x]]))
  }, character(1), USE.NAMES=FALSE)
  str2lang(paste(var, " <- ", .cls, "(", paste(.retD, collapse=","),")"))
}