Nothing
`PLOTR` <-function(
run,
...,
project=getwd(),
rundir=filename(project,run),
grp = NULL,
onefile=TRUE,
plotfile=plotfilename(run,project,grp,onefile),
logtrans = FALSE,
dvname = 'DV',
epilog=NULL,
grpnames = NULL,
cont.cov = NULL,
cat.cov = NULL,
par.list = NULL,
eta.list = NULL,
missing = -99,
estimated = NULL,
superset = FALSE
){
if(superset) data <- .dataSuperset(
run=run,
project=project,
logtrans=logtrans,
grp=grp,
grpnames=grpnames,
cont.cov=cont.cov,
cat.cov=cat.cov,
par.list=par.list,
eta.list=eta.list,
missing=missing,
rundir=rundir,
...
)
else data <- dataSynthesis(
run=run,
project=project,
logtrans=logtrans,
grp=grp,
grpnames=grpnames,
cont.cov=cont.cov,
cat.cov=cat.cov,
par.list=par.list,
eta.list=eta.list,
missing=missing,
rundir=rundir,
...
)
write.csv(data,filename(rundir,ext='_syn.csv'),row.names=FALSE)
available <- names(data)
cont.cov <- strain(cont.cov,available)
cat.cov <- strain(cat.cov,available)
par.list <- strain(par.list,available)
eta.list <- strain(eta.list,available)
listfilename <- file.path(rundir,glue(run,'.lst'))
listfile <- readLines(listfilename)
iterations <- try(iterations(listfile))
it.dat <- NULL
if(inherits(iterations,'data.frame'))try(it.dat <- melt(iterations,measure.var=names(iterations)[contains('X',names(iterations))]))
if(!is.null(estimated)){
if(any(duplicated(estimated)))warning('estimated contains duplicates and will not be used')
else try(levels(it.dat$variable) <- estimated)
}
#make plots
tryCatch(list(),error = function(e) list())
di <- tryCatch(diagnosticPlots(data, dvname=dvname, group='grpnames', model= paste('Model',run),...),error = function(e) list())
co <- tryCatch(covariatePlots(data,cont.cov,cat.cov,par.list,eta.list,...),error = function(e) list())
cw <- tryCatch(cwresPlots(data,cont.cov,cat.cov,...),error = function(e) list())
it <- if(is.null(it.dat)) list() else c(
tryCatch(
list(parameter=
xyplot(
value~iteration|variable,
it.dat[it.dat$course=='parameter',],
main= paste('Model',run,'parameter search'),
type='l',ylab='scaled parameter',as.table=TRUE,
scales=list(y=list(relation='free'))
)
),
error = function(e)list()
),
tryCatch(
list(gradient=
xyplot(
value~iteration|variable,
it.dat[it.dat$course=='gradient',] ,
main= paste('Model',run,'gradient search'),
type='l',ylab='gradient',as.table=TRUE,
scales=list(y=list(relation='free')),
panel=function(...){
panel.abline(h=0)
panel.xyplot(...)
}
)
),
error = function(e)list()
)
)
plots <- c(di, co, cw, it)
#open device
plotfile <- star(plotfile,run)
safe.call(pdf,file=plotfile,onefile=onefile,...)
lapply(
seq_along(plots),
function(i){
nm <- names(plots)[[i]]
if(is.null(nm) || is.na(nm) || nm == '') nm <- 'unnamed'
plot <- plots[[i]]
msg <- paste('error printing',nm, 'plot')
standby <- xyplot(1~1,panel=ltext,label=msg)
tryCatch(print(plot),error=function(e)print(standby))
}
)
#cleanup
dev.off()
unlink(filename(rundir,ext='_syn.csv'))
message('Plotting for run ', run, ' complete.')
#try epilog
script <- NULL
epimatch <- try(match.fun(epilog),silent=TRUE)
if(is.function(epimatch))epilog <- epimatch
else if (class(epilog)=='character'){
script <- epilog
epilog <- episcript
}
if (!is.null(epilog))if(is.function(epilog))try(
epilog(
run=run,
project=project,
dvname=dvname,
logtrans=logtrans,
grp=grp,
grpnames=grpnames,
cont.cov=cont.cov,
cat.cov=cat.cov,
par.list=par.list,
eta.list=eta.list,
missing=missing,
rundir=rundir,
...,
script=script
)
)
invisible(data)
}
#filters elipses for functions that do not accept them
safe.call <- function(what,...){
extras <- list(...)
legal <- names(formals(what))
extras <- extras[names(extras) %in% legal]
do.call(what=what,args=extras)
}
#creates a filepath from dir,run, and extension
filename <- function(dir,run=NULL,ext=NULL)file.path(dir,glue(run,ext))
#calculates a vector of cwres
getCwres <- function(directory){
cwrtab1 <- filename(directory, NULL, 'cwtab1.deriv')
if (!file.exists(cwrtab1)) stop(cwrtab1,' does not exist.',call.=FALSE)
tab.prefix <- filename(directory,NULL, '/cwtab')
cwres.all<-compute.cwres(
run.number=1,
tab.prefix=tab.prefix,
printToOutfile=TRUE
)
data.cwres <- read.table(
file = filename(directory,NULL, '/cwtab1'),
skip = 1,
header = TRUE
)
data.cwres$CWRES
}
#loads non-null cwres onto tab file
setCwres <- function(cwres,file){
cwres <- c('CWRES',cwres)
tabdata<- readLines(file)[-1]
if(length(tabdata)!=length(cwres))stop('cwres-tabfile length mismatch',call.=FALSE)
msg <- paste('CWRES added', format(Sys.time(), '%a %b %d, %X, %Y'))
tabdata <- paste(tabdata,cwres)
tabdata <- c(msg,tabdata)
writeLines(tabdata,con = file)
}
#finds the nonmem data set and coverts it to a covariate file
getCovs <- function(file,dir){
here <- getwd()
setwd(dir)
tryCatch(
suppressWarnings(
covdata <- read.table(file = file, header = TRUE, as.is = TRUE, sep = ',')
),
error=function(e)stop(file,' not visible from ',dir,call.=FALSE),
finally=setwd(here)
)
if('C' %in% names(covdata))covdata <- covdata[covdata$C != 'C',]
if(!'ID' %in% names(covdata))stop('ID not a column in ',file,call.=FALSE)
covdata <- covdata[!duplicated(covdata$ID),]
if(!nrow(covdata))stop(file,' has no rows',call.=FALSE)
return(covdata)
}
#returns the parameter file
getPars <- function(file){
if (!file.exists(file))stop(file,' does not exist.',call.=FALSE)
f <- read.table(file = file, header = TRUE, skip = 1)
if(!'ID' %in% names(f))stop('ID not a column in ',file,call.=FALSE)
f <- f[!duplicated(f$ID),]
if(!nrow(f))stop(file,' has no rows',call.=FALSE)
return(f)
}
#scavenges the data set name/path from the control stream
getdname <- function (x,...)UseMethod('getdname')
getdname.default <- function(x,...){
if (!file.exists(x)) stop(x, " not found", call. = FALSE)
control <- read.nmctl(x)
getdname(control)
}
getdname.nmctl <- function(x,...){
if (!"data" %in% names(x))stop("data record not found in control stream")
x$data <- sub("^ +", "", x$data)
x$data <- x$data[!x$data == ""]
sub("^([^ ]+).*$", "\\1", x$data[[1]])
}
#finds the tab file and reduces it to observation rows
getTabs <- function(file){
if (!file.exists(file))stop(file,' does not exist.',call.=FALSE)
tabdata <- read.table(file = file, header = TRUE, as.is = TRUE, skip = 1, comment.char = '')
if(!'EVID' %in% names(tabdata))stop('EVID not a column in ',file,call.=FALSE)
tabdata <- tabdata[tabdata$EVID == 0, ]
if(!nrow(tabdata))stop(file,' has no rows',call.=FALSE)
tabdata
}
#melds the grpnames columns into one, renaming levels conditionally
groupnames <- function(data,grp,grpnames=NULL,run){
result <- factor(
do.call(
paste,
c(
as.list(data[,grp,drop=FALSE]),
sep=", "
)
)
)
nlevs <- length(levels(result))
if(!is.null(grpnames))if(length(grpnames)==nlevs)levels(result) <- grpnames
if(!is.null(grpnames))if(length(grpnames)!=nlevs)warning(call.=FALSE,immediate.=TRUE,'Run ',run,' has ',nlevs,' grouping levels but ',length(grpnames),' grpnames (ignored).' )
result
}
#combines any number of tables using left join to load the columns specified in x
synthesis <- function(x,key=character(0),frames,...){
if(any(sapply(frames,function(x)!inherits(x,'data.frame'))))stop()
x <- unique(x)
y <- frames[[1]]
frames[[1]] <- NULL
x <- setdiff(x,names(y))
while (length(x) & length(frames)){
z <- frames[[1]]
frames[[1]] <- NULL
z <- z[, union(key, intersect(x, names(z))),drop=FALSE]
z <- z[!duplicated(z[, intersect(names(z), names(y))]),,drop=FALSE]
if(length(setdiff(names(z),names(y)))) y <- stableMerge(y,z)
x <- setdiff(x,names(y))
}
y
}
#reduces a character vector to the subset found in options
strain <- function(x,options){
if(!is.null(x))x <- intersect(x,options)
x
}
#back transforms cols in x
backtrans <- function(x,cols){
for(col in cols)x[[col]] <- exp(x[[col]])
x
}
#generates the plotting data set, given actual data frames, etc.
dataFormat <- function(
tabdata,
covdata,
pardata,
logtrans=FALSE,
grp=NULL,
grpnames=NULL,
cont.cov=NULL,
cat.cov=NULL,
par.list=NULL,
eta.list=NULL,
missing=-99,
run,
...
){
if (logtrans) tabdata <- backtrans(tabdata,intersect(names(tabdata),c('DV',.predvar())))
available <- unique(c(names(tabdata),names(covdata),names(pardata)))
grp <- strain(grp,available)
cont.cov <- strain(cont.cov,available)
cat.cov <- strain(cat.cov,available)
par.list <- strain(par.list,available)
eta.list <- strain(eta.list,available)
findAnywhere <- c(grp,cont.cov,cat.cov)
findInOutput <- c(par.list,eta.list)
data <- synthesis(findAnywhere, key='ID',frames=list(tabdata,pardata,covdata),...)
data <- synthesis(findInOutput, key='ID',frames=list(data,tabdata,pardata),...)
missing <- as.numeric(as.character(missing))
for(col in cont.cov) data[[col]] <- as.numeric(as.character(data[[col]]))
for(col in cont.cov) data[[col]][!is.na(data[[col]]) & data[[col]]==missing] <- NA
if(is.null(grp))data$grpnames <- 'all'
if(is.null(grp))grp <- 'grpnames'
data$grpnames <- groupnames(data,grp,grpnames,run)
data
}
# alternate generation of data format
.dataSuperset <- function(
run,
project=getwd(),
logtrans=FALSE,
rundir=filename(project, run),
ctlfile = filename(rundir,run,'.ctl'),
grp= NULL,
grpnames= NULL,
cont.cov= NULL,
cat.cov= NULL,
par.list= NULL,
eta.list= NULL,
missing=-99,
...
){
data <- superset(run=run,project=project,rundir=rundir,ctlfile=ctlfile,...)
data <- as.best(data)
data <- data[!!data[as.character(run)],,drop=FALSE]
if(logtrans) data <- backtrans(data,intersect(names(data),c('DV',c(.predvar()))))
available <- names(data)
grp <- strain(grp,available)
cont.cov <- strain(cont.cov,available)
cat.cov <- strain(cat.cov,available)
par.list <- strain(par.list,available)
eta.list <- strain(eta.list,available)
missing <- as.numeric(as.character(missing))
for(col in cont.cov) data[[col]] <- as.numeric(as.character(data[[col]]))
for(col in cont.cov) data[[col]][!is.na(data[[col]]) & data[[col]]==missing] <- NA
if(is.null(grp))data$grpnames <- 'all'
if(is.null(grp))grp <- 'grpnames'
data$grpnames <- groupnames(data,grp,grpnames,run)
data
}
#generates the plotting data set, given project, run, etc.
dataSynthesis <- function(
run,
project=getwd(),
logtrans = FALSE,
grp = NULL,
grpnames = NULL,
cont.cov = NULL,
cat.cov = NULL,
par.list = NULL,
eta.list = NULL,
missing = -99,
rundir = filename(project, run),
ctlfile = filename(rundir,run,'.ctl'),
outfile = filename(rundir,run,'.lst'),
datfile = getdname(ctlfile),
...
){
#cleanup arguments
force(datfile)
if (!file.exists(outfile))stop(outfile,' does not exist.',call.=FALSE)
if (!file.exists(ctlfile))stop(ctlfile,'does not exist.',.call.=FALSE)
ctlfile <- read.nmctl(ctlfile)#switch from file name to file content
#outputrecords <- as.character(ctlfile[names(ctlfile)=='table'])
outputrecords <- as.character(ctlfile[names(ctlfile) %contains% 'tab'])
tabfile <- tryCatch(tabfile(outputrecords,dir=rundir,...),error=function(e)stop('cannot locate *.tab in control stream for run ',run,call.=FALSE))
parfile <- tryCatch(parfile(outputrecords,dir=rundir,...),error=function(e)stop('cannot locate *par.tab in control stream for run ',run,call.=FALSE))
#acquire data
tabdata <- getTabs(tabfile)
covdata <- getCovs(datfile,rundir)
pardata <- getPars(parfile)
#process data
data <- dataFormat(
tabdata=tabdata,
covdata=covdata,
pardata=pardata,
logtrans=logtrans,
grp=grp,
grpnames=grpnames,
cont.cov=cont.cov,
cat.cov=cat.cov,
par.list=par.list,
eta.list=eta.list,
missing=missing,
run=run,
...
)
data
}
star <- function(x,y)gsub('*', y, x, fixed=TRUE)
plotfilename=function(
run,
dir=getwd(),
grp=NULL,
onefile=TRUE,
stem='DiagnosticPlotReview',
pext=if(onefile)'.pdf' else '_%03d.pdf',
...
)filename(
dir,
glue(
stem,
paste(grp,collapse=''),
'_',
run
),
pext
)
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.