R/create_xposeNlme.R

In Certara.Xpose.NLME: Enhances 'xpose' Diagnostics for Pharmacometric Models from 'Certara.RsNLME' and Phoenix NLME

create_xposeNlme <-
  function(modelName,
           dmp.txt,
           listInput,
           nlme7engineLines,
           ConvergenceData,
           dir,
           progresstxt,
           problem = 1,
           Sort = NULL,
           xp = NULL) {
    requiredNames <- c(
      "coefficients",
      "logLik",
      "nObs",
      "nSubj",
      "nParm",
      "returnCode",
      "cols1.txt",
      "residuals",
      "posthoc"
    )
    stopifnot(class(dmp.txt) %in% c("list", "nlme"),
              length(setdiff(requiredNames, names(dmp.txt))) == 0)

    mapping <- dmp.txt$cols1.txt
    ofv <- as.character(-2 * dmp.txt$logLik)
    nind <- as.character(dmp.txt$nSubj)
    nobs <- as.character(dmp.txt$nObs)
    stparm <- dmp.txt$posthoc
    residuals <- dmp.txt$residuals
    etas <- dmp.txt$coefficients$random$Subject
    returnCode <- dmp.txt$returnCode

    input <- listInput$input
    unitsPresent <- listInput$unitsPresent
    optionalUnits <- listInput$optionalUnits
    TimeBased <- listInput$TimeBased
    IDcol <- listInput$IDcol

    # all covariates are presented in posthoc
    # renaming them in the input data if the column name is the same as the model name
    # (adding '_input')
    # merge them from stparm since they are complete
    CovModelNames <- getCovModelNames(mapping)
    mappedCovariates <-
      get_mappedCovariates(CovModelNames, input, mapping)

    # proceeding structural parameters in dmp
    # note that it is assumed to have mode=keep
    listInputStparm <-
      prepare_inputStparm(input, stparm, IDcol, TimeBased, CovModelNames)
    stparm <- listInputStparm$stparm
    inputStparm <- listInputStparm$inputStparm
    stnames <- listInputStparm$stnames

    d1 <-
      prepare_inputStparmResid(inputStparm, residuals, IDcol, TimeBased)

    d1List <-
      join_d1Etas(d1, data.frame(etas))
    rnames <- d1List$rnames

    d1 <- add_EVID(d1List$d1)

    catcovNames <-
      get_catcovNames(mapping, mappedCovariates)
    contcovNames <-
      get_contcovNames(mapping, mappedCovariates)

    data_ind <- create_data_ind(d1,
                                stnames,
                                catcovNames,
                                contcovNames,
                                rnames,
                                optionalUnits,
                                unitsPresent)

    data <- tibble::tibble(
      problem = problem,
      simtab = F,
      index = list(data_ind),
      data = list(d1),
      modified = F
    )

    data <- sort_dataID(data, IDcol)

    epsShrinkage <- get_epsilonShrinkage(nlme7engineLines)
    etaShrinkage <- get_etaShrinkage(nlme7engineLines, rnames)
    method <- get_method(nlme7engineLines)
    runtime <- get_runtime(nlme7engineLines)
    covtime <- get_covtime(nlme7engineLines)
    term <- get_term(returnCode)

    # load convergence data
    ConvergenceDF <-
      .load_convergenceData(ConvergenceData, dir, progresstxt, method, problem)
    prmDF <- .create_prmDF(dmp.txt, method, problem)
    overallDF <- .create_overallDF(dmp.txt, method, problem)

    dir <- ifelse(dir == "", getwd(), dir)

    labels1 <-
      c(
        "descr",
        "ofv",
        "epsshk",
        "etashk",
        "run",
        "nind",
        "nobs",
        "dir",
        "method",
        "runtime",
        "covtime",
        "term"
      )

    if (is.null(Sort)) Sort <- ""
    values1 <-
      c(
        Sort,
        ofv,
        epsShrinkage,
        etaShrinkage,
        modelName,
        nind,
        nobs,
        dir,
        method,
        runtime,
        covtime,
        term
      )

    summary1 <-
      tibble::tibble(
        problem = problem,
        subprob = 0,
        label = labels1,
        value = values1
      )

    summary1 <- add_descrXpose(summary1)

    software <- "phx/nlme"

    if (!is.null(xp)) {
      stopifnot(inherits(xp, "xpose_data"))

      files <- dplyr::bind_rows(xp$files, ConvergenceDF, prmDF, overallDF)
      data <- dplyr::bind_rows(xp$data, data)
      summary <-
        dplyr::bind_rows(xp$summary, summary1)

      if (!identical(xp$code, dmp.txt$".\\test.mdl")) {
        stop("Code provided for in the database is not the same as in the new files provided.")
      }

      if (!identical(xp$software, dmp.txt$".\\test.mdl")) {
        stop("Code provided for in the database is not the same as in the new files provided.")
      }
    } else {
      labels0 <- c("software", "version")
      values0 <- c(software, "8.3")
      summary <-
        tibble::tibble(
          problem = 0,
          subprob = 0,
          label = labels0,
          value = values0
        )

      summary <- add_descrXpose(summary)

      summary <-
        dplyr::bind_rows(summary, summary1)

      files <- dplyr::bind_rows(ConvergenceDF, prmDF, overallDF)
    }

    gg_theme <- xpose::theme_readable()
    xp_theme <- xpose::theme_xp_default()

    xp <- list(
      code = dmp.txt$".\\test.mdl",
      files = files,
      summary = summary,
      data = data,
      software = software,
      gg_theme = gg_theme,
      xp_theme = xp_theme,
      options = list(dir = NULL, quiet = T)
    ) %>%
      structure(class = c("xpose_data", "uneval"))

    xp <- xpose::update_themes(xp, xp_theme = list(line_alpha = NA))

    xp
  }