R/create_prmDF.R

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

# removing comments from the model statements
.remove_commentsWhites <- function(statementsLines) {
  if (is.list(statementsLines)) {
    statementsLines <- unlist(statementsLines)
  }

  if (length(statementsLines) > 1) {
    statementsLines <- paste(statementsLines, collapse = "\n")
  }

  statementsLines <- gsub("\r\n",
                          "\\n",
                          statementsLines)

  OneLine2Slash <- "(?:\\/\\/(?:\\\\\\n|[^\\n])*(?=$|\\n))"
  OneLineSharp <- "(?:#(?:\\\\\\n|[^\\n])*(?=$|\\n))"
  Asterisk <- "(?:\\/\\*[\\s\\S]*?\\*\\/)"

  pattern <- paste(OneLine2Slash,
                   OneLineSharp,
                   Asterisk,
                   sep = "|",
                   collapse = "|")

  statementsLineswoComm <-
    gsub(pattern, "\n", statementsLines, perl = TRUE)

  statementsLineswoComm <- gsub("[\r\n \t]|\\(\\)",
                                "",
                                paste0(statementsLineswoComm, collapse = ""))
  statementsLineswoComm
}

.get_sigmas <-
  function(dmptxtSigma,
           fixedSigmas,
           fixedSigmasSE,
           dmptxtFixed) {
    fixedSigmasNames <- colnames(fixedSigmas)
    if (!is.null(dmptxtSigma)) {
      sigmas <-
        data.frame(value = sqrt(diag(as.matrix(dmptxtSigma))))
      sigmas <- tibble::rownames_to_column(sigmas, var = "label")
      sigmas <- tibble::rowid_to_column(sigmas, var = "sigmaid")

      sigmas <-
        dplyr::mutate(
          sigmas,
          type = "sig",
          name = paste0("SIGMA(", sigmaid, ",", sigmaid, ")"),
          diagonal = TRUE,
          m = sigmaid,
          n = sigmaid
        )

      sigmas <- dplyr::select(sigmas, -sigmaid)

      if (!is.null(fixedSigmasSE)) {
        sigmas <-
          dplyr::left_join(sigmas, fixedSigmasSE, by = "label")
        sigmas <-
          dplyr::mutate(sigmas, rse = se / abs(value))
      } else {
        sigmas <-
          dplyr::mutate(sigmas,
                        se = NA,
                        rse = NA)
      }

      fixedNames <- setdiff(fixedSigmasNames, sigmas$label)
      fixed <- data.frame(value = fixedSigmas[, fixedNames])
    } else {
      fixed <- data.frame(value = dmptxtFixed)
      sigmas <- tibble::tibble()
    }

    list(fixed = fixed, sigmas = sigmas)
  }

#' @importFrom magrittr %>%
.get_thetas <- function(fixed, fixedSigmasSE) {
  fixed <-
    tibble::rownames_to_column(fixed, var = "label") %>%
    tibble::rowid_to_column(var = "thetaid") %>%
    dplyr::mutate(
      type = "the",
      name = paste0("THETA(", thetaid, ")"),
      diagonal = NA,
      m = thetaid,
      n = NA
    ) %>%
    dplyr::select(-thetaid)

  if (!is.null(fixedSigmasSE)) {
    fixed <-
      dplyr::left_join(fixed, fixedSigmasSE, by = "label") %>%
      dplyr::mutate(fixed, rse = se / abs(value))
  } else {
    fixed <-
      dplyr::mutate(fixed,
                    se = NA,
                    rse = NA)
  }

  fixed
}

#' @importFrom magrittr %>%
.get_secondaries <-
  function(dmptxtSecondary, dmptxtStderrSecondary) {
    if (!is.null(dmptxtSecondary)) {
      secondary <-
        data.frame(value = dmptxtSecondary) %>%
        tibble::rownames_to_column(var = "label") %>%
        tibble::rowid_to_column(var = "secondaryid") %>%
        dplyr::mutate(
          type = "sec",
          name = paste0("SECONDARY(", secondaryid, ")"),
          diagonal = NA,
          m = secondaryid,
          n = NA
        ) %>%
        dplyr::select(-secondaryid)

      if (!is.null(dmptxtStderrSecondary)) {
        secondary$se <- dmptxtStderrSecondary
        secondary <- dplyr::mutate(secondary, rse = se / abs(value))
      } else {
        secondary <-
          dplyr::mutate(secondary,
                        se = NA,
                        rse = NA)
      }
    } else {
      secondary <- tibble::tibble()
    }
  }

#' @importFrom magrittr %>%
.get_omegas <- function(dmptxtOmega, dmptxtOmegaSE) {
  if (!is.null(dmptxtOmega)) {
    omegamatrix <- dmptxtOmega
    omegaNames <- colnames(omegamatrix)
    omegas <- tibble::tibble()
    for (Row in 1:nrow(omegamatrix)) {
      for (Col in 1:ncol(omegamatrix)) {
        if (Col > Row) {
          next()
        }

        if (Row == Col) {
          omegaLabel <- omegaNames[Row]
        } else {
          omegaLabel <- paste0(omegaNames[Row], "-", omegaNames[Col])
        }

        omegaName <- paste0("OMEGA(", Row, ",", Col, ")")
        omegaDiag <- Row == Col
        if (!is.null(dmptxtOmegaSE)) {
          se <- dmptxtOmegaSE[omegaNames[Row], omegaNames[Col]]

          rse <- ifelse(omegamatrix[Row, Col] == 0,
                        NA,
                        se / abs(omegamatrix[Row, Col]))
        } else {
          se <- NA
          rse <- NA
        }

        omegaRow <- data.frame(
          type = "ome",
          label = omegaLabel,
          name = omegaName,
          value = omegamatrix[Row, Col],
          se = se,
          rse = rse,
          diagonal = omegaDiag,
          m = Row,
          n = Col
        )
        omegas <- dplyr::bind_rows(omegas, omegaRow)
      }
    }
  } else {
    omegas <- tibble::tibble()
  }

  omegas
}

#' @importFrom magrittr %>%
.get_frozen <-
  function(pmlLinesWOComm,
           sigmas,
           omegas,
           prmTablewoFreeze) {
    fixefUncleanedBlocks <-
      strsplit(pmlLinesWOComm, "fixef")[[1]][-c(1)]
    fixefUncleanedList <-
      regmatches(
        fixefUncleanedBlocks,
        gregexpr("\\((?:[^)(]+|(?R))*+\\)",
                 fixefUncleanedBlocks,
                 perl = TRUE)
      )
    # remove non-fixefs
    fixefBlocks <- sapply(fixefUncleanedList, function(x) {
      x[1]
    })
    # remove enable
    fixefBlocks <- gsub("\\(enable=c\\(\\d+\\)\\)", "", fixefBlocks)

    if (nrow(sigmas) > 0) {
      sigmasUncleanedBlocks <-
        strsplit(pmlLinesWOComm, "error")[[1]][-c(1)]
      sigmasUncleanedList <-
        regmatches(
          sigmasUncleanedBlocks,
          gregexpr("\\((?:[^)(]+|(?R))*+\\)",
                   sigmasUncleanedBlocks,
                   perl = TRUE)
        )
      sigmasBlocks <- sapply(sigmasUncleanedList, function(x) {
        x[1]
      })
    } else {
      sigmasBlocks <- ""
    }

    if (nrow(omegas) > 0) {
      ranefUncleanedBlocks <-
        strsplit(pmlLinesWOComm, "ranef")[[1]][-c(1)]
      ranefUncleanedList <-
        regmatches(
          ranefUncleanedBlocks,
          gregexpr("\\((?:[^)(]+|(?R))*+\\)",
                   ranefUncleanedBlocks,
                   perl = TRUE)
        )
      ranefBlocks <- sapply(ranefUncleanedList, function(x) {
        x[1]
      })
    } else {
      ranefBlocks <- ""
    }


    fixedColumn <-
      vector(mode = "logical", length = nrow(prmTablewoFreeze))

    for (Row in 1:nrow(prmTablewoFreeze)) {
      if (prmTablewoFreeze$type[Row] == "the") {
        if (length(grep(
          paste0(
            "[\\(\\)\\d\\,]",
            prmTablewoFreeze$label[Row],
            "\\(freeze\\)="
          ),
          fixefBlocks
        )) > 0) {
          fixedColumn[Row] <- TRUE
        }
      } else if (prmTablewoFreeze$type[Row] == "sig") {
        if (length(grep(
          paste0("\\(", prmTablewoFreeze$label[Row], "\\(freeze\\)="),
          sigmasBlocks
        )) > 0) {
          fixedColumn[Row] <- TRUE
        }
      } else if (prmTablewoFreeze$type[Row] == "ome" &&
                 any(grepl("freeze", ranefBlocks))) {
        OmegaName <- strsplit(prmTablewoFreeze$label[Row], "-")[[1]]
        if (length(OmegaName) == 2) {
          # one of the omega names should be in the block
          pattern <-
            paste0(
              "[\\,\\(](",
              OmegaName[1],
              "|",
              OmegaName[2],
              ")[\\W\\)][^\\(]*(?=\\(freeze\\))"
            )
        } else {
          pattern <-
            paste0(
              "(",
              OmegaName,
              "\\W|[\\,\\(]",
              OmegaName,
              "[\\W\\)][^\\(]*)(?=\\(freeze\\))"
            )
        }

        if (any(grepl(pattern, ranefBlocks, perl = TRUE))) {
          fixedColumn[Row] <- TRUE
        }
      }
    }

    fixedColumn
  }

#' @importFrom magrittr %>%
.create_prmDF <- function(dmp.txt, method, problem = 1) {
  fixedSigmas <- t(data.frame(dmp.txt$coefficients$fixed))

  if (!is.null(dmp.txt$varFix)) {
    # thetas and sigmas SE exists
    fixedSigmasSE <-
      data.frame(se = sqrt(diag(as.matrix(dmp.txt$varFix))))

    fixedSigmasSE <-
      tibble::rownames_to_column(fixedSigmasSE, var = "label")
  } else {
    fixedSigmasSE <- NULL
  }

  # sigmas
  fixedSigmaList <- .get_sigmas(
    dmptxtSigma = dmp.txt$sigma,
    fixedSigmas,
    fixedSigmasSE,
    dmptxtFixed = dmp.txt$coefficients$fixed
  )

  sigmas <- fixedSigmaList$sigmas

  # thetas
  fixed <- .get_thetas(fixedSigmaList$fixed, fixedSigmasSE)

  # secondaries
  secondary <- .get_secondaries(dmp.txt$coefficients$secondary,
                                dmp.txt$stderrSecondary)

  # omegas
  omegas <- .get_omegas(dmp.txt$omega,
                        dmp.txt$omegaSE)

  prmTablewoFreeze <-
    dplyr::bind_rows(fixed, sigmas, omegas, secondary)
  pmlLines <- dmp.txt[[length(dmp.txt) - 1]]
  pmlLinesWOComm <- .remove_commentsWhites(pmlLines)
  frozen <-
    .get_frozen(pmlLinesWOComm, sigmas, omegas, prmTablewoFreeze)
  prmTableUnordered <-
    dplyr::bind_cols(prmTablewoFreeze, fixed = frozen)
  prmTable <-
    dplyr::select(
      prmTableUnordered,
      c(
        "type",
        "name",
        "label",
        "value",
        "se",
        "rse",
        "fixed",
        "diagonal",
        "m",
        "n"
      )
    )

  prmTableDF <- tibble::tibble(
    name = "prmTable",
    extension = "csv",
    problem = problem,
    subprob = 0,
    method = method,
    data = list(tibble::as_tibble(prmTable)),
    modified = FALSE
  )

  prmTableDF
}