Nothing
`runNonmem` <-
function (
run,
...,
command,
project,
wait,
checkrunno,
diag,
fdata,
epilog,
dvname,
logtrans,
grp,
grpnames,
cont.cov,
cat.cov,
par.list,
eta.list,
missing,
invisible,
checksum,
grid,
nice,
udef,
compile,
execute,
split,
plotfile=plotfilename(run,project,grp),
rundir = filename(project,run),
outfile = filename(rundir,run,'.lst'),
streams = project,
ctlfile = filename(streams,run,'.ctl'),
purge = TRUE,
sync=if(wait)'y'else'n',
interface='nm.pl',
perm.cond=NULL,
pe=NA
){
# Note: runNonmem calls runCommand, which supports the qsub argument 'pe';
# it also calls PLOTR, which supports the trellis.skeleton argument 'perm.cond'.
# If 'pe' is passed to runNonmem, trellis.skeleton partial-matches it as 'perm.cond'.
# To disambiguate, runNonmem should declare at least one of them, and pass explicitly.
# Currently we declare 'perm.cond' and pass only to PLOTR. Thus, trellis.skeleton
# always receives a fully-named 'perm.cond' (with the usual default value)
# and will do no partial matching.
#Define some functions.
#final <- function(x)sub('\\.lock','',x)
#Groom arguments.
rundir <- star(rundir,run)
ctlfile <- star(ctlfile,run)
outfile <- star(outfile,run)
catfile <- filename(rundir,run,'.cat')
pnmfile <- sub('ctl$','pnm',ctlfile) # to support copy of pnm file where present
pltfile <- filename(streams,'template','.pnm')
prnfile <- filename(dirname(command),'template','.pnm')
#Immediately we need to get the run directory and cat file open, or return an error.
if(command!='')if(compile){
#purge.dir(final(rundir),nice)
purge.dir(rundir,nice)
#if(rundir!=final(rundir))purge.dir(rundir) #deliberately not "nice"
if(!file.exists(dirname(rundir)))stop('cannot find ',dirname(rundir))
if(!file.exists(rundir))if(!dir.create(rundir))stop('cannot create ',rundir)
cat(date(),file=catfile,sep='\n') #append is FALSE
}
#Continue
if(!file.exists(ctlfile)){
msg <- glue(ctlfile,' not found')
cat(msg,file=catfile,append=TRUE,sep='\n')
return(msg)
}
control <- read.nmctl(ctlfile)
#outputdomain <- names(control) =='table' | contains('est',names(control))
outputdomain <- names(control) %contains% 'tab|est'
control[outputdomain] <- lapply(control[outputdomain],explicitPath)
if (checkrunno) {
problemdomain <- contains('prob',names(control))
control[problemdomain] <- lapply(control[problemdomain],fixProblem,run=run)
control[outputdomain] <- lapply(control[outputdomain],fixFile,run=run)
write.nmctl(control,file=ctlfile)
}
tabfile <- ''
parfile <- ''
msffile <- ''
control <- as.character(control[outputdomain])
tryCatch(tabfile <- tabfile(control,dir=rundir,...),error=function(e)cat('cannot locate *.tab in control stream for run ',file=catfile,append=TRUE,sep='\n'))
tryCatch(parfile <- parfile(control,dir=rundir,...),error=function(e)cat('cannot locate *par.tab in control stream for run ',file=catfile,append=TRUE,sep='\n'))
tryCatch(msffile <- msffile(control,dir=rundir,...),error=function(e)cat('cannot locate *.msf in control stream for run ',file=catfile,append=TRUE,sep='\n'))
#tabfile <- try(tabfile(control,dir=final(rundir),...))
#parfile <- try(parfile(control,dir=final(rundir),...))
#msffile <- try(msffile(control,dir=final(rundir),...))
script <- NULL
epimatch <- try(match.fun(epilog),silent=TRUE)
if(is.function(epimatch))epilog <- epimatch
else if (class(epilog)=='character'){
script <- epilog
epilog <- episcript
}
#Prepare the file environment.
if(command!='')if(compile){
if(file.exists(plotfile))file.remove(plotfile)
if(file.exists(outfile))file.remove(outfile)
if(file.exists(tabfile))file.remove(tabfile)
if(file.exists(parfile))file.remove(parfile)
if(file.exists(msffile))file.remove(msffile)
dname <- getdname(ctlfile)
#The next error trap is redundant: prevents identical trap in getCovs()
if(!file.exists(resolve(dname,rundir))){
msg <- glue(dname,' not visible from ',rundir)
cat(msg,file=catfile,append=TRUE,sep='\n')
return(msg)
}
file.copy(ctlfile, file.path(rundir,basename(ctlfile)), overwrite = TRUE)
#parallelization
if(is.defined(pe)){
if(file.exists(pnmfile)) file.copy(pnmfile,file.path(rundir,basename(pnmfile)),overwrite=TRUE)
else if(file.exists(pltfile))file.copy(pltfile,file.path(rundir,basename(pnmfile)),overwrite=TRUE)
else if(file.exists(prnfile))file.copy(prnfile,file.path(rundir,basename(pnmfile)),overwrite=TRUE)
else(cat('pe is defined, but parallelization file not found',file=catfile,append=TRUE,sep='\n'))
}
}
#Run NONMEM.
if(command=='')res <- ''
else res <- runCommand(
command=command,
run=run,
rdir=rundir,
wait=wait,
checksum=checksum,
grid=grid,
udef=udef,
ctlfile=file.path(rundir,basename(ctlfile)),
outfile=outfile,
invisible=invisible,
compile=compile,
execute=execute,
split=split,
sync=sync,
interface=interface,
pe=pe,
...
)
#Clean up.
if(execute){
#if (and only if?) this is an unsynchronized run on the grid,
#we may have reached here before the run is complete. So we return without post-processing (diagnostics and cleanup).
if(sync=='n' & grid)return(res)
if(purge)purgeRunDir(dirs=rundir,debug=!fdata,...)
#if(rundir!=final(rundir)){
#dir.create(final(rundir), showWarnings = FALSE)
#file.copy(from=dir(rundir,full.names=TRUE),to=final(rundir),overwrite=TRUE)
#purge.dir(rundir)
#rundir <- final(rundir)
#catfile <- final(catfile)
#}
#Diagnostics
if(!udef)
if(command!='' & interface=='nm.pl')if(nmVersion(config(dirname(command))) < 7)
tryCatch(
setCwres(
cwres=getCwres(
directory=rundir
),
file=tabfile
),
error=function(e)cat(e$message,file=catfile,append=TRUE,sep='\n')
)
if(diag)tryCatch(
PLOTR(
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,
ctlfile=ctlfile,
outfile=outfile,
rundir=rundir,
plotfile=plotfile,
perm.cond=perm.cond,
...
),
error=function(e)cat(e$message,file=catfile,append=TRUE,sep='\n')
)
if (!is.null(epilog))if(is.function(epilog))tryCatch(
epilog(
run=run,
project=project,
dvname=dvname,
logtrans=logtrans,
grp=grp,
grpames=grpnames,
cont.cov=cont.cov,
cat.cov=cat.cov,
par.list=par.list,
eta.list=eta.list,
missing=missing,
ctlfile=ctlfile,
outfile=outfile,
rundir=rundir,
perm.cond=perm.cond,
...,
script=script
),
error=function(e)cat(e$message,file=catfile,append=TRUE,sep='\n')
)
message("Run ", run, " complete.")
}
return(res)
}
#.............................................................................
purge.dir <- function(dir,nice=FALSE){
if(file_test('-d',dir)){
files <- dir(dir,full.names=TRUE,all.files=!nice)
files <- files[!files %in% grep('\\.$',files,value=TRUE)]
isDir <- file_test('-d',files)
if(length(files[!isDir]))file.remove(files[!isDir])
lapply(files[isDir],purge.dir,nice=nice)
if(!nice)unlink(dir, recursive=TRUE)
}
}
purge.files <- function(pattern,dir='.'){
if(file_test('-d',dir)){
files <- dir(dir)
files <- grep(pattern,files,value=TRUE,ignore.case=TRUE)
#if(length(files))file.remove(paste(dir,files,sep='/'))
if(length(files)) files <- paste(dir,files,sep='/')
lapply(files[file_test('-f',files)],file.remove)
lapply(files[file_test('-d',files)],purge.dir)
}
}
episcript <- function(script,...){
extras <- list(...)
args <- names(extras)
lapply(
args,
function(x,extras)assign(x,extras[[x]],envir=parent.frame(2)),
extras
)
try(source(script,local=TRUE))
}
fixProblem <- function(x,run)sub('(^ *(RUN#? *)?)([^ ;]+)(.*$)',glue('\\1',run,'\\4'),x,ignore.case=TRUE)
fixFile <- function(x,run){
x <- explicitPath(x)
risk <- grep('\\bTAB\\b|\\bMSF\\b',x,ignore.case=TRUE)
#except <- grep('\\bMSFI\\b',x,ignore.case=TRUE)
#risk <- setdiff(risk,except)
dir <- dirname(x)
base <- basename(x)
#very hard to detect (par).*, because of greedy matching
#try searching from the end
backwards <- function(x){
x <- strsplit(x,NULL)
x <- lapply(x,rev)
x <- lapply(x,paste,collapse='')
x <- unlist(x)
x
}
#base <- sub("^[^.(par)]+", run, base)
base <- backwards(base)
base <- sub('(^[^.]+\\.(rap)?).*','\\1',base)
base <- backwards(base)
base <- glue(run,base)
x[risk] <- file.path(dir[risk], base[risk])
x
}
explicitPath <- function(x){
risk <- grep('\\.TAB\\b|\\.MSF\\b',x,ignore.case=TRUE)
except <- grep('/',x)
risk <- setdiff(risk,except)
x[risk] <- sub('^(.*\\W)?(\\w*)(\\.msf|\\.tab)(.*)$','\\1./\\2\\3\\4',x[risk],ignore.case=TRUE)
x
}
extractPath <- function(x)sub('(^.*(MSFO?|FILE) *= *)([^ ]*)(.*$)','\\3',x,ignore.case=TRUE)
resolve <- function(file,dir)ifelse(contains('^\\.',file),file.path(dir,file),file)
scavenge <- function(expr,lines){
x <- lines[grep(expr,lines,ignore.case=TRUE, perl=TRUE)]
if(!length(x))stop('expression ',expr,' not found',call.=FALSE)
x[[1]]
}
extfile <- function(ctlfile,dir,extreg,...){
x <- scavenge(extreg,ctlfile)
x <- extractPath(x)
x <- resolve(x,dir)
x
}
tabfile <- function(ctlfile,dir,tabreg='(?<!par)\\.tab',...)tryCatch(
extfile(ctlfile,dir,extreg=tabreg,...),
error=function(e)stop('cannot locate *.tab in control stream for ',dir,call.=FALSE)
)
parfile <- function(ctlfile,dir,parreg='par\\.tab',...)tryCatch(
extfile(ctlfile,dir,extreg=parreg,...),
error=function(e)stop('cannot locate *par.tab in control stream for ',dir,call.=FALSE)
)
msffile <- function(ctlfile,dir,msfreg='^(?!\\$MSFI).*\\.msf',...)tryCatch(
extfile(ctlfile,dir,extreg=msfreg,...),
error=function(e)stop('cannot locate *.msf in control stream for ',dir,call.=FALSE)
)
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.