R/xposeNlmeUtils.r

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

# check the file path given in NLME directory
.check_filePath <- function(NLMEFile, dir, stopErr = TRUE) {
  if (dirname(NLMEFile) == ".") { # file without path is given
    if (dir == "") { # dir argument is empty
      wdNLMEfile <- file.path(getwd(), NLMEFile)
      if (file.exists(wdNLMEfile)) {
        NLMEFile <- wdNLMEfile
      } else {
        if (stopErr) {
          stop("File ", NLMEFile, " is not found. ",
            "\nPlease check the path.",
            call. = FALSE
          )
        }
      }
    } else { # dir argument is not empty
      wdNLMEfile <- file.path(dir, NLMEFile)
      if (file.exists(wdNLMEfile)) {
        NLMEFile <- wdNLMEfile
      } else {
        if (stopErr) {
          stop("File ", NLMEFile, " not found in\n",
            dir,
            "\nPlease check the path.",
            call. = FALSE
          )
        }
      }
    }
  } else { # file with path is given
    NLMEFile <- path.expand(NLMEFile)
    if (!file.exists(NLMEFile) & stopErr) {
      stop("File ", NLMEFile, " is not found. ",
        "\nPlease check the path.",
        call. = FALSE
      )
    }
  }

  NLMEFile
}


# lookupMappedColumn looks at column mapping and maps a column
lookupMappedColumn <- function(inputColnames, mapping, colName, warn = TRUE, pattern = NULL) {
  if (is.null(pattern)) {
    pattern <- paste0("^\\W*", colName, "\\W*\\([^\\)]*\\)")
  }

  lineNumbers <- grep(pattern, mapping)

  if (length(lineNumbers) == 0L) {
    if (warn) {
      warning("No lines with ", colName, "  map found in column definition:",
        paste(mapping, collapse = "\n"),
        call. = FALSE
      )
    }
  }

  foundColumns <- character(0)
  for (lineNo in lineNumbers) {
    if (colName == "id") {
      foundColumn <- unlist(strsplit(mapping[lineNo], "(((^\\W*id\\W*\\(\\W*))*|([\"\']\\W*,\\W*)*)[\"\']\\W*\\)*"))
      foundColumn <- foundColumn[foundColumn != ""]
    } else {
      foundColumn <- unlist(strsplit(mapping[[lineNo]], "\""))[[2]]
    }

    foundColumns <- c(foundColumns, foundColumn)

    if (length(foundColumn) != 0) {
      colsNotFound <- setdiff(foundColumn, inputColnames)
      if (length(colsNotFound) != 0) {
        if (warn) {
          warning("Column(s) ", paste(colsNotFound, collapse = ", "),
            "\n mapped in cols1 not found in data column names.",
            call. = FALSE
          )
        }
      }
    } else {
      if (warn) {
        warning("Mapped columns not found in the statement:\n", mapping[lineNo])
      }
    }
  }

  if (length(foundColumns) == 0) {
    return("")
  } else {
    return(foundColumn)
  }
}

.prepare_covariates <- function(xpdb, covColNames) {
  indexTibble <- xpdb$data$index[[1]]
  catcovColNames <- indexTibble$col[indexTibble$type == "catcov"]
  contcovColNames <- indexTibble$col[indexTibble$type == "contcov"]

  if (missing(covColNames)) {
    if (length(catcovColNames) == 0 && length(contcovColNames) == 0) {
      stop("No covariates found; Cannot build the plot.")
    }
  } else {
    stopifnot(all(is.character(covColNames)))
    notFoundCovariates <- setdiff(covColNames, c(contcovColNames, catcovColNames))
    if (length(notFoundCovariates) > 0) {
      stop(
        "The following covarate(s) are not in the covariate list of xpdb object:\n",
        paste(notFoundCovariates, collapse = ", ")
      )
    }

    catcovColNames <- setdiff(covColNames, contcovColNames)
    contcovColNames <- setdiff(covColNames, catcovColNames)
  }

  list(catcovColNames = catcovColNames, contcovColNames = contcovColNames)
}

#' @importFrom rlang .data
.get_eta_names <- function(index) {
  etas <- index %>%
    dplyr::filter(.data$type == "eta") %>%
    dplyr::select(col) %>%
    unlist(use.names = FALSE)

  return(etas)
}

#' @importFrom rlang .data
.get_param_names <- function(index) {
  params <- index %>%
    dplyr::filter(.data$type == "param") %>%
    dplyr::select(col) %>%
    unlist(use.names = FALSE)

  return(params)
}

#' @importFrom rlang .data
.get_cat_cov <- function(index) {
  catcovColNames <- index %>%
    dplyr::filter(.data$type == "catcov") %>%
    dplyr::select(col) %>%
    unlist(use.names = FALSE)

  return(catcovColNames)
}

#' @importFrom rlang .data
.get_cont_cov <- function(index) {
  contCovColNames <- index %>%
    dplyr::filter(.data$type == "contcov") %>%
    dplyr::select(col) %>%
    unlist(use.names = FALSE)

  return(contCovColNames)
}

.is_numeric_vector <- function(vec) {
  grepl("^([-]?[0-9]+[.]?[0-9]*|[-]?[0-9]+[L]?|[-]?[0-9]+[.]?[0-9]*[eE][0-9]+)$", vec)
}