#' @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)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.