R/read_extfile.R

In ggPMX: 'ggplot2' Based Tool to Facilitate Diagnostic Plots for NLME Models

# This code is strongly based on the read_nmext function of mrgsolve (nmxml.R) (Thanks to Kyle T Baron)


#' Reads .ext files generated by NONMEM
#'
#' @param run run a run number or run identifier
#' @param project project the NONMEM project directory
#' @param file file the `ext` file name
#' @param path path full path and file name for `ext` file
#' @param read_fun read_fun function to read the `ext` file
#' @param quiet Logical, if \code{FALSE} messages are printed to the console.
#' 
#' @author This function is based on read_nmext from mrgsolve, Original Author: Kyle T Baron.
#' This function has some changes to the original code:
#'Addition of param, "quiet", (option of pmx_msg function, from xpose package) (Line: 27)
#'The code was slightly adjusted to check for multiple tables and also extract SE (ITERATION == 1000000001) (Line: 44-58, Line: 86-96, respectively)
#'The output was also slightly adjusted to fit ggPMX output (df and df2) (Line: 105,106)
#'as_bmat was replaced by bmat_like to create the diagonal matrix (Line 116:142)
#'
#' @return A list with param, omega, and sigma in a format 
#' ready to be used. 

#' @export
#'
#' @examples
#' #project <- system.file("nonmem", package = "mrgsolve") 
#' #est <- read_nmext(1005, project = project) 

read_extfile <- function(run=NA_real_, project = getwd(), file=paste0(run,".ext"), 
                       path=NULL, read_fun = c("data.table","read.table"),quiet) {
  
  if(is.character(path)) {
    extfile <- path  
  } else {
    extfile <- file.path(project,run,file)
  }
  
  if(!file.exists(extfile)) {
    stop("[read_nmext] could not find the requested 'ext' file ", 
         shQuote(basename(extfile)))
  }
  
  read_fun <- match.arg(read_fun)
  
  use_dt <- requireNamespace("data.table",quietly=TRUE) & read_fun=="data.table"
  
  ## Check for multiple tables/problems
  
  ext_tmp <- readLines(extfile)
  inds  <- grep("TABLE",ext_tmp)
  last_table <- 0

  ## Check if multiple Problems are found in .ext file
  
  if (length(inds)!=1){
    last_table <- inds[length(inds)]
    colon <- regexpr(":",ext_tmp[last_table])[1]
    last_table_name <- substr(ext_tmp[last_table],1,colon-1)
    last_table <- last_table-1
    pmx_msg(paste("Multiple Problems found in",file,"only using",last_table_name,"\n"),quiet) #multiple problems not currently supported, only using last table
  }
  
  ## Read .ext file
  
  if(use_dt) {
    df <- data.table::fread(
      file=extfile, 
      na.strings = '.', 
      data.table=FALSE,
      skip=last_table+1
    )
  } else {
    df <- read.table(
      file=extfile,
      na.strings='.',
      stringsAsFactors=FALSE,
      skip=last_table+1, 
      header=TRUE
    )
  }
  
  ## Get parameters and standard errors
  
  #get parameters
  ans <- ""
  ans <- df[df[["ITERATION"]] == -1E9,]
  bmat_ans <- ans #in order to use bmat_like function
  df_ans <- ans
  
  
  #get standard erros
  ans_se <- ""
  ans_se <- df[df[["ITERATION"]] == -1000000001,]
  df_ans_se <- ans_se
  
  if(nrow(ans)==0) {
    stop(
      "[read_nmext] could not find final estimates",
      " while reading 'ext' file ", shQuote(basename(extfile))
    )
  }

  #get numbers of "OMEGA" or "SIGMA" used in bmat_like
  get_num <- function(x,string){ #last_om = x
    
    nums <- gsub(paste0(".*",string,"|[()]"), "", x)
    
    num1 <- as.numeric(gsub(",.*", "", nums))
    num2 <- as.numeric(gsub(".*,", "", nums))
    
    num_vec <- c(num1,num2)
    
    return(num_vec)
    
  }
  
  #uses bmat_ans as an input and gives out diagonal matrix
  bmat_like <- function(x,string) {
    y <- x[grep(string,names(x))]
    len_y <- length(y)
    nam_last_om <- names(y[len_y])
    z <- substring(nam_last_om, regexpr(",", nam_last_om) + 1)
    num <- as.numeric(sub(').*', '', z))
    pre_mat <- matrix(nrow = num, ncol = num)
    mat <- pre_mat
    mat[] <- 0
    
    i <- 1
    for (i in i:len_y) {
      om <- y[i]
      nam_om <- names(om)
      pos <- get_num(nam_om,string)
      mat[pos[1],pos[2]] <- om[[1]]
    }
    
    return(mat)
  }
  
  ans <- as.list(ans)
  names(ans) <- gsub("[[:punct:]]", "", names(ans))
  ans <- list(
    param = ans[grepl("THETA", names(ans))],
    omega = bmat_like(bmat_ans, "OMEGA"), 
    sigma = bmat_like(bmat_ans, "SIGMA"),
    raw = ans,
    df = df_ans,
    df2 = df_ans_se
  )
  return(ans)
}