R/create.parameter.list.R

Defines functions create.parameter.list

Documented in create.parameter.list

#' @describeIn read_NM_output Reads parameters, uncertainty and termination messages included in a
#' NONMEM output file
#' @export
#' 
create.parameter.list  <- function(listfile)
{
  ## Read list file
  if(is.readable.file(listfile)) {
    x <- read.lst(listfile)
    if(length(x)==0 && x == 0) {
      cat("The output file does not contain any information")
      return()
    }
  } else {
    cat("The output file couldn't be found in the current directory.\n")
    return()
  }
  
  ## Count the number of parameters
  npar.list   <- calc.npar(x)
  
  #attach(npar.list, warn.conflicts=F)
  
  npar <- npar.list$npar
  nth <- npar.list$nth
  nseth <- npar.list$nseth
  nom <- npar.list$nom
  nseom <- npar.list$nseom
  nsi <- npar.list$nsi
  nsesi <- npar.list$nsesi
  
  
  
  seenterm <- seenobj <- seenth <- seenom <- seensi <- seenseth <- seenseom <-
    seensesi <- seennth <- seennom <- 0
  #attach(x, warn.conflicts=F)
  
  term <- x$term
  ofv <- x$ofv
  thetas <- x$thetas
  omega <- x$omega
  sigma <- x$sigma
  sethetas <- x$sethetas
  seomegas <- x$seomegas
  sesigmas <- x$sesigmas
  
  
  if(!any(is.null(term)))
    seenterm <- 1
  if(!any(is.null(ofv)))
    seenobj <- 1
  if(!any(is.null(thetas)))
    seenth <- 1
  if(!any(is.null(omega)) && nom !=0)
    seenom <- 1
  if(!any(is.null(sigma)) && nsi !=0)
    seensi <- 1
  if(!any(is.null(sethetas)))
    seenseth <- 1
  if(!any(is.null(seomegas)) && nseom !=0)
    seenseom <- 1
  if(!any(is.null(sesigmas)) && nsesi !=0)
    seensesi <-1
  
  ## Add parameters
  
  ## Construct the parameter information that is to be added to the screen
  ## This will be in the form of 1 or two arrays, the first being the array
  ## with parameter estimates and the second with SEs
  ## The nonparametrics are added to the parameter array afterwards
  ## The SE array will be constructed wether or not there are SE but filled
  ## with 0.
  
  ## If we haven't got any parameters in the lst-file
  if(seenth != 1) {
    cat("No parameters found, check your NONMEM output file.\n")
    return()
  }
  
  ## If we have thetas (we should have them!)
  if(seenth == 1) {
    nth           <- length(thetas)
    parnam        <- 0
    parval        <- 0
    parnam[1:nth] <- paste("TH",1:nth,sep="")
    parval[1:nth] <- format.default(thetas,digits=2)
  }
  
  ## If we have SE for the thetas
  if(seenseth == 1) {
    nseth           <- length(sethetas)
    separnam        <- 0
    separval        <- 0
    separnam[1:nseth] <- paste("RSE TH",1:nseth,sep="")
    
    ## To avoid division by zero or NA
    selzero           <- thetas == 0
    selna             <- is.na(sethetas)
    sel <- !selzero & !selna
    sel1              <- !sel
    cvthetas          <- 0
    cvthetas[sel] <- format.default(sethetas[sel]/abs(thetas[sel]),digits=2)
    cvthetas[sel1]    <- ""
    separval[1:nseth] <- cvthetas
  } else {
    nth             <- length(thetas)
    separnam        <- 0
    separval        <- 0
    separnam[1:nth] <- paste("RSE TH",1:nth,sep="")
    separval[1:nth] <- 0
  }
  
  ## If we have omegas
  if(seenom == 1 ) {
    nomega <- length(omega)
    for(i in 1:nomega) {
      sel <- omega[[i]] != 0
      if(nomega == 1) sel <- T
      if(i == 1) sel <- T
      if(length(omega[[i]][sel]) == 1 || i == 1) {        # Must be a diagonal omega
        
        parnam[length(parnam)+1]  <- paste("OM",i,":",i,sep="")
        
        ## If the first omega is fixed to 0
        if(omega[[i]][sel] == 0) {
          parval[length(parval)+1]  <-
            format.default(0,digits=2)
          ##separnam[length(separnam)+1]  <- paste("CT OM",i,":",i,sep="")
          separval[length(separval)+1]  <- ""
        } else {
          
          parval[length(parval)+1]  <-
            format.default(sqrt(omega[[i]][sel]),digits=2)
          separnam[length(separnam)+1]  <- paste("CT OM",i,":",i,sep="")
          separval[length(separval)+1]  <- ""
        }
        
        
      } else { # There are off-diagonals or the whole row is zero
        
        ## The diagonal element
        parnam[length(parnam)+1]  <- paste("OM",i,":",i,sep="")
        parval[length(parval)+1]  <-
          format.default(sqrt(omega[[i]][i]),digits=2)
        
        separnam[length(separnam)+1]  <- paste("CT OM",i,":",i,sep="")
        separval[length(separval)+1]  <- ""
        
        ## Loop over the off-diagonals
        for(j in 1:(length(omega[[i]])-1)) {
          
          if(omega[[i]][j] == 0) next
          if(omega[[i]][j] != 0) {
            parnam[length(parnam)+1]  <- paste("OM",i,":",j,sep="")
            parval[length(parval)+1]  <-
              format.default(omega[[i]][j]/sqrt(omega[[i]][i]*omega[[j]][j]),digits=2)
            
            separnam[length(separnam)+1]  <- paste("CT OM",i,":",j,sep="")
            separval[length(separval)+1]  <- ""
          }
        }
      }
    }
  }
  
  ## If we have SE for the omegas -- fill in their values
  if(seenseom == 1) {
    n <- length(thetas)           # n - is a flag that makes the values appear
    #     in the right place
    nseomega <- length(seomegas)
    for(i in 1:nseomega) {
      ## Select the non-zero omegas
      sel <- omega[[i]] != 0
      
      if(nseomega == 1) sel <- T
      if(i == 1) sel <- T
      
      if(length(seomegas[[i]][sel]) == 1) {
        ## Must be a diagonal omega
        
        n <- n+1
        separnam[n] <-
          paste("RSE OM",i,":",i,sep="")
        
        if(omega[[i]][sel] == 0) { ## If first omega is fixed to 0
          separval[n]  <- ""
        } else {
          if(is.na(seomegas[[i]][sel])){
            separval[n]  <- ""
          } else {  
            if(seomegas[[i]][sel] == 0){
              separval[n]  <- ""
            } else {
              separval[n]  <-
                format.default(seomegas[[i]][sel]/abs(omega[[i]][sel]),digits=2)
            }
          }
        }
        
      } else {
        ## There are off-diagonals
        n <- n+1
        separnam[n]  <- paste("RSE OM",i,":",i,sep="")
        if(is.na(seomegas[[i]][i])){
          separval[n]  <- ""
        } else {
          if(seomegas[[i]][i] == 0){
            separval[n]  <- ""
          } else {
            separval[n]  <-
              format.default(seomegas[[i]][i]/abs(omega[[i]][i]),digits=2)
          }
        }
        
        ## Loop over the off-diagonals
        for(j in 1:(length(seomegas[[i]])-1)) {
          if(omega[[i]][j] == 0) next
          if(omega[[i]][j] != 0) {
            n <- n +1
            separnam[n]  <-
              paste("RSE OM",i,":",j,sep="")
            if(is.na(seomegas[[i]][j])){
              separval[n]  <- ""
            } else {
              if(seomegas[[i]][j] == 0){
                separval[n]  <- ""
              } else {
                separval[n]  <-
                  format.default(seomegas[[i]][j]/abs(omega[[i]][j]),digits=2)
              }
            }
          }
        }
      }
    }
  }
  
  ## capture the length of the parameter vector before sigma added
  th.om.par.length <- length(parnam)
  
  ## If we have sigmas
  if(seensi == 1) {
    nsigma <- length(sigma)
    for(i in 1:nsigma) {
      sel <- sigma[[i]] != 0
      
      if(length(sigma[[i]][sel]) == 1) {        # Must be a diagonal omega
        
        parnam[length(parnam)+1]  <- paste("SI",i,":",i,sep="")
        parval[length(parval)+1]  <-
          format.default(sqrt(sigma[[i]][sel]),digits=2)
        
        separnam[length(separnam)+1]  <- paste("RSE SI",i,":",i,sep="")
        separval[length(separval)+1]  <- ""
        
      } else {                                  # There are off-diagonals
        ## The diagonal element
        parnam[length(parnam)+1]  <- paste("SI",i,":",i,sep="")
        parval[length(parval)+1]  <-
          format.default(sqrt(sigma[[i]][i]),digits=2)
        
        separnam[length(separnam)+1]  <- paste("RSE SI",i,":",i,sep="")
        separval[length(separval)+1]  <- ""
        
        ## Loop over the off-diagonals
        for(j in 1:(length(sigma[[i]])-1)) {
          if(sigma[[i]][j] == 0) next
          if(sigma[[i]][j] != 0) {
            parnam[length(parnam)+1]  <- paste("SI",i,":",j,sep="")
            parval[length(parval)+1]  <-
              format.default(sigma[[i]][j]/sqrt(sigma[[i]][i]*sigma[[j]][j]),digits=2)
            separnam[length(separnam)+1]  <- paste("RSE SI",i,":",j,sep="")
            separval[length(separval)+1]  <- ""
          }
        }
      }
    }
  }
  
  ## If we have SE for the sigmas -- fill in their values
  if(seensesi == 1) {
    n <- th.om.par.length
    
    nsesigma <- length(sesigmas)
    for(i in 1:nsesigma) {
      sel <- sigma[[i]] != 0
      
      if(nsesigma == 1) sel <- T
      
      if(length(sesigmas[[i]][sel]) == 1) {
        ## Must be a diagonal omega
        n <- n+1
        separnam[n]<- paste("RSE SI",i,":",i,sep="")
        if(sigma[[i]][sel] == 0) {
          ## If first sigma is fixed to 0
          separval[n]<- ""
        } else {
          if(is.na(sesigmas[[i]][sel])){
            separval[n]  <- ""
          } else {
            if(sesigmas[[i]][sel] == 0){
              separval[n]  <- ""
            } else {
              separval[n]<-
                format.default(sesigmas[[i]][sel]/abs(sigma[[i]][sel]),digits=2)
            }
          }
        }
      } else {
        ## There are off-diagonals
        n <- n+1
        separnam[n]<- paste("RSE SI",i,":",i,sep="")
        if(is.na(sesigmas[[i]][i])){
          separval[n]  <- ""
        } else {
          if(sesigmas[[i]][i] == 0) {
            separval[n]  <- ""
          } else {
            separval[n]<-
              format.default(sesigmas[[i]][i]/abs(sigma[[i]][i]),digits=2)
          }
        }
        ## Loop over the off-diagonals
        for(j in 1:(length(sesigmas[[i]])-1)) {
          
          if(sigma[[i]][j] == 0) next
          if(sigma[[i]][j] != 0) {
            n <- n+1
            separnam[n] <-
              paste("RSE SI",i,":",j,sep="")
            if(is.na(sesigmas[[i]][j])){
              separval[n]  <- ""
            } else {
              if(sigma[[i]][j] == 0){
                separval[n]  <- ""
              } else {
                separval[n] <-
                  format.default(sesigmas[[i]][j]/abs(sigma[[i]][j]),digits=2)
              }
            }
          }
        }
      }
    }
  }
  
  
  ret.list <- list(term = term, ofv = ofv,
                   seenterm = seenterm,
                   seenobj = seenobj,
                   seenth = seenth,
                   seenom = seenom,
                   seensi = seensi,
                   seenseth = seenseth,
                   seenseom = seenseom,
                   seensesi = seensesi,
                   npar = npar,
                   parnam = parnam,
                   parval = parval,
                   separnam = separnam,
                   separval = separval
  )
  
  
  
  #detach(x)
  #detach(npar.list)
  
  return(ret.list)
  
}
UUPharmacometrics/xpose4 documentation built on Feb. 22, 2024, 5:02 p.m.