#############################################################################################
## Project: PKgraph
## File: functionOK.R
## Author: Xiaoyong Sun
## Date: 11/02/2009
## Goal: note
## - interface between function.R and proto.R
## Notes:
################################################################################
## global function
################################################################################
getSubHeight <- function() .pk$getSubHeight()
getSubWidth <- function() .pk$getSubWidth()
getTerm <- function() .pk$getTerm()
setTerm <- function(term.df) .pk$setTerm(term.df)
getValidateData <- function() .pk$getValidateData()
setValidateData <- function(vdata) .pk$setValidateData(vdata)
getNameDataSpecialPlot <- function() .pk$getNameDataSpecialPlot()
## for some ggobi data, it is not directly from main screen. data need some modification,
## e.g. absoluate value, etc.
getDataSpecialPlot <- function(i) .pk$getDataSpecialPlot(i)
setDataSpecialPlot <- function(tdata, tname) .pk$setDataSpecialPlot(tdata, tname)
cleanDataSpecialPlot <- function() .pk$cleanDataSpecialPlot()
getDataLayoutPlot <- function() .pk$getDataLayoutPlot()
setDataLayoutPlot <- function(tdata) .pk$setDataLayoutPlot(tdata)
cleanDataLayoutPlot <- function() .pk$cleanDataLayoutPlot()
getDatasets <- function() .pk$getDatasets()
setDatasets <- function(tmp.data, dataname) .pk$setDatasets(tmp.data, dataname)
getTotalDataLen <- function() .pk$getTotalDataLen()
getTotalDataName <- function() .pk$getTotalDataName()
getCurrentData <- function(currentNo)
{
if (missing(currentNo))
{
currentMain <- svalue(pmg.dialog.notebook)
.pk$getCurrentData(currentMain)
}
else
{
.pk$getCurrentData(currentNo)
}
}
getCurrentDataType <- function(currentNo) .pk$getCurrentDataType(currentNo)
setCurrentDataType <- function(thisDataType, dataname) .pk$setCurrentDataType(thisDataType, dataname)
getItDataName <- function() .pk$getItDataName()
setItDataName <- function(itname) .pk$setItDataName(itname)
getItMap <- function() .pk$getItMap()
setItMap <- function(key) .pk$setItMap(key)
getComDataName <- function() .pk$getComDataName()
setComDataName <- function(itname) .pk$setComDataName(itname)
getComMap <- function() .pk$getComMap()
setComMap <- function(key.df) .pk$setComMap(key.df)
getCall <- function(package, plotType)
{
if (package == "lattice")
{
if (plotType=="hist") mycall <- "histogram"
else if (plotType=="scatter") mycall <- "xyplot"
else if (plotType=="smatrix") mycall <- "splom"
else if (plotType=="bwplot") mycall <- "bwplot"
}
else
{
if (plotType=="hist") mycall <- "qplot"
else if (plotType=="scatter") mycall <- "qplot"
else if (plotType=="smatrix") mycall <- "plotmatrix"
}
return(mycall)
}
getPKCode <- function(i) .pk$getPKCode(i)
setPKCode <- function(newlist) .pk$setPKCode(newlist)
cleanPKCode <- function() .pk$cleanPKCode()
getPKGGobi <- function(i) .pk$getPKGGobi(i)
setPKGGobi <- function(newx) .pk$setPKGGobi(newx)
cleanPKGGobi <- function() .pk$cleanPKGGobi()
getSaveFormat <- function() .pk$getSaveFormat()
setSaveFormat <- function(newformat) .pk$setSaveFormat(newformat)
getFigConfig <- function() .pk$getFigConfig()
setFigConfig <- function(newconfig) .pk$setFigConfig(newconfig)
getGGobiPlotType <- function(currentNo) .pk$getGGobiPlotType(currentNo)
setGGobiPlotType <- function(typelist, dataname) .pk$setGGobiPlotType(typelist, dataname)
ggobiPlotType <- function()
{
currentMain <- svalue(pmg.dialog.notebook)
ggobi.map = gwindow("Configure interactive graphics", horizontal=FALSE)
gtgroup1 = ggroup(cont=ggobi.map, horizontal=FALSE)
gf1 <- gframe(text = "", markup = FALSE, pos = 0, horizontal=TRUE, container = gtgroup1)
tbl <- glayout(cont=gf1)
cline <- 0
tbl.list <- list()
tbl.list[[1]] = gdroplist(items=colnames(getCurrentData(currentMain)))
tbl.list[[2]] = gdroplist(items=colnames(getCurrentData(currentMain)))
tbl.list[[3]] = gdroplist(items=colnames(getCurrentData(currentMain)))
name.order <- colnames(getCurrentData(currentMain))
if (length(getGGobiPlotType()) != 0)
{
current.list <- getGGobiPlotType(currentMain)
if (length(current.list) > 0)
{
ID.index <- match(current.list$ID, name.order)
tbl.list[[1]] <- gdroplist(items=c(name.order[c(ID.index)], name.order[-ID.index]))
Time.index <- match(current.list$Time, name.order)
tbl.list[[2]] <- gdroplist(items=c(name.order[c(Time.index)], name.order[-Time.index]))
Conc.index <- match(current.list$Conc, name.order)
tbl.list[[3]] <- gdroplist(items=c(name.order[c(Conc.index)], name.order[-Conc.index]))
}
}
dataname <- c("ID variable:", "Time variable:", "Concentration variable(DV):")
for (i in 1: length(dataname))
{
cline <- cline + 1
tbl[cline, 1, anchor = c(-1,-1)] = dataname[i]
#tbl.list[[i]] = gdroplist(items=colnames(getCurrentData()))
tbl[cline, 2, anchor = c(-1,-1)] = tbl.list[[i]]
}
gb1 = gbutton(text="Set PK data type", horizontal=FALSE )
addhandlerclicked(gb1, function(h,...)
{
key <- list( ID=svalue(tbl.list[[1]]) , Time=svalue(tbl.list[[2]]),
Conc=svalue(tbl.list[[3]]))
setGGobiPlotType(key, as.character(currentMain))
tmp.data <- getCurrentData(currentMain)
tmp.name <- getTotalDataName()[currentMain]
tmp.data[,key$ID] <- factor(tmp.data[,key$ID])
setDatasets(tmp.data, tmp.name)
dispose(ggobi.map)
svalue(pmg.statusBar) <- "Data types are configured successfully."
})
cline <- cline + 1
tbl[cline, 2, anchor = c(-1,-1)] = gb1
}
cleanAll <- function() .pk$cleanAll()
## Goal: repeat code for runing ggobi time series plot
ggobiRun <- function()
{
currentMain <- svalue(pmg.dialog.notebook)
ggobi.data <- getCurrentData(currentMain)
Time.name <- getGGobiPlotType(as.character(currentMain))$Time
Conc.name <- getGGobiPlotType(as.character(currentMain))$Conc
ID.name <- getGGobiPlotType(as.character(currentMain))$ID
if (!is.null(Time.name))
{
## rearrange time, conc as the first and second variable
time.ind <- which(colnames(ggobi.data)== Time.name)
conc.ind <- which(colnames(ggobi.data)== Conc.name)
old.ind <- c(1:length(colnames(ggobi.data)))
ggobi.data <- ggobi.data[c(time.ind, conc.ind, old.ind[-c(time.ind, conc.ind)])]
ggobi.text <- paste("g <- ggobi_longitudinal(ggobi.data", Time.name, ID.name, ")", sep=",")
eval(parse(text=ggobi.text))
}
else
{
g <- ggobi(ggobi.data)
}
return(g)
}
## check data exist
checkDataExist <- function()
{
current.no <- svalue(pmg.dialog.notebook)
if (current.no == 0) return(FALSE)
tmp.data <- getCurrentData(current.no)
if (is.null(tmp.data))
{
return(FALSE)
}
else return(TRUE)
}
## check data type
checkDataType <- function(requiredType)
{
currentDataNo <- svalue(pmg.dialog.notebook)
dataType <- getCurrentDataType(currentDataNo)
if (dataType==requiredType) return(TRUE)
else return(FALSE)
}
## check data config
checkDataConfig <- function()
{
if (nrow(getTerm()) > 0) return(TRUE)
else return(FALSE)
}
checkSaveFormat <- function()
{
if (length(getSaveFormat()) > 0) return(TRUE)
else return(FALSE)
}
checkforPKModel <- function()
{
## check data exist
if(!checkDataExist())
{
gmessage("No data is available for configuration!",
icon=c("warning"), title="Warning")
return(FALSE)
}
## check dataType is "Data"
if(!checkDataType(requiredDataType.PKmodel))
{
gmessage("The current data set is NOT DATA type!",
icon=c("warning"), title="Warning")
return(FALSE)
}
## check data configure
if (!checkDataConfig())
{
gmessage("Data is Not configured. Please use Menu: PK Models, Configure model result!",
icon=c("warning"), title="Warning")
return(FALSE)
}
return(TRUE)
}
ErrorMessage <- function(mymessage)
{
gmessage(mymessage, icon="warning", title="warning")
}
################################################################################
## OK button for function.R and proto.R
################################################################################
## "cond" mainly for lattice, NOT for ggplot2
addList1 <- function(mylist, x, package, cond)
{
if (package == "lattice")
{
if (missing(cond)) mylist$x <- formula(paste("~", x, sep=""))
else mylist$x <- formula(paste("~", x, " | ", cond, sep=""))
}
else
{
mylist$x <- as.name(x)
}
mylist$xlab <- x
#mylist$main <- x
return(mylist)
}
addList2 <- function(mylist, x, y, package, cond)
{
if (package == "lattice")
{
if (missing(cond)) mylist$x <- formula(paste(y, "~", x, sep=""))
else mylist$x <- formula(paste(y, "~", x, " | ", cond, sep=""))
mylist$xlab <- x
mylist$ylab <- y
#mylist$main <- paste(y, "vs", "x", sep=" ")
}
else
{
mylist$x <- as.name(x)
mylist$y <- as.name(y)
mylist$xlab <- x
mylist$ylab <- y
#mylist$main <- paste(y, "vs", "x", sep=" ")
}
return(mylist)
}
## TODO later; now only for individual plots
translateList <- function(para.list, config.list)
{
mylist <- list()
## check data x exist
if (para.list[["x"]]=="")
{
gmessage("Please choose x value!", icon=c("warning"), title="Warning")
return(mylist)
}
mypackage <- config.list[["graphics"]]
# decide call & list
if (mypackage == "lattice")
{
## decide call
if (para.list[["y"]]=="") mycall <- "histogram"
else mycall <- "xyplot"
## decide list
# - choose x or y
# - choose condition
if (para.list[["y"]]=="")
{
if (config.list[["cond"]]=="") mylist <- addList1(mylist, para.list[["x"]], mypackage)
else mylist <- addList1(mylist, para.list[["x"]], mypackage, config.list[["cond"]])
}
else
{
if (config.list[["cond"]]=="") mylist <- addList2(mylist, para.list[["x"]], para.list[["y"]],mypackage)
else mylist <- addList2(mylist, para.list[["x"]], para.list[["y"]], mypackage, config.list[["cond"]])
}
# - choose type
if (para.list[["type"]]!="")
{
mylist$type <- para.list[["type"]]
}
# - choose layout
mylist$layout <- as.numeric(c(config.list[["layout_x"]], config.list[["layout_y"]]))
}
else
{
mycall <- "qplot"
## REMEMBER:
# - choose condition is DONE in the last step, since do.call syntax NOT work for ggplot2
# - choose x or y
if (para.list[["y"]]=="")
{
mylist <- addList1(mylist, para.list[["x"]], mypackage)
}
else
{
mylist <- addList2(mylist, para.list[["x"]], para.list[["y"]], mypackage)
}
# - choose type
if (para.list[["type"]]!="")
{
mylist$geom <- switch(para.list[["type"]],
p = c("point"),
l = c("line"),
psmooth = c("point", "smooth"),
lsmooth = c("line", "smooth"),
percent = c("histogram"),
count = c("histogram"),
density = c("histogram")
)
}
}
# - choose xlab, ylab
if (para.list[["xlab"]]!="") mylist$xlab <- para.list[["xlab"]]
if (para.list[["ylab"]]!="") mylist$xlab <- para.list[["ylab"]]
# - choose main
if (para.list[["main"]]!="") mylist$xlab <- para.list[["main"]]
return(list(mycall=mycall, mylist=mylist))
}
extractSimData <- function(dir.path, folder.name, file.name, id.var, cond.var)
{
final.df <- NULL
old.pwd <- getwd()
on.exit(setwd(old.pwd))
try1 <- try(setwd(dir.path), silent=TRUE)
if (inherits(try1, "try-error"))
{
ErrorMessage("Path is wrong! Please input right path.")
return(invisible(NULL))
}
else
{
target.dir <- dir(pattern=folder.name)
sapply(1:length(target.dir), function(i)
{
if (file.name %in% list.files(path=target.dir[i]))
{
fileName <- paste(target.dir[i], file.name, sep="/")
sim.data <- read.table(fileName, header=T, skip=1)
mydata <- unique(sim.data[,c(id.var, cond.var)])
## if cond.var is non-subject-specific,
## - abs.sum or abs.sum^2
if (nrow(mydata) != length(unique(mydata[[id.var]])))
{
mydata[[cond.var]] <- abs(mydata[[cond.var]])
mean.tmp <- tapply(mydata[[cond.var]], list(mydata[[id.var]]), mean, simplify=TRUE, na.rm=TRUE)
mydata <- data.frame(unique(mydata[[id.var]]), mean.tmp)
colnames(mydata) <- c(id.var, cond.var)
}
}
else
{
ErrorMessage("There is no such file in these folders!")
return(invisible(NULL))
}
rowLabel <- "resample"
thisName <- paste(rowLabel, i, sep="")
final.df[[thisName]] <<- mydata[[cond.var]]
return(invisible(NULL))
})
}
return(final.df)
}
extractCddData <- function(dir.path, folder.name, file.name, id.var, cond.var, total.id, rowLabel)
{
final.df <- NULL
v.delete.id <- NULL
old.pwd <- getwd()
on.exit(setwd(old.pwd))
try1 <- try(setwd(dir.path), silent=TRUE)
if (inherits(try1, "try-error"))
{
ErrorMessage("Path is wrong! Please input right path.")
return(invisible(NULL))
}
else
{
target.dir <- dir(pattern=folder.name)
if (length(target.dir)==0)
{
ErrorMessage("In the Target directory, there is NO such folder pattern!")
return(invisible(NULL))
}
sapply(1:length(target.dir), function(i)
{
if (file.name %in% list.files(path=target.dir[i]))
{
fileName <- paste(target.dir[i], file.name, sep="/")
sim.data <- read.table(fileName, header=T, skip=1)
if (!all(c(id.var, cond.var) %in% colnames(sim.data)))
{
ErrorMessage(paste("In simulation folder - ", target.dir[i], ", Patiend ID or Plot variable
does not match the NONMEM result file !", sep=""))
return(invisible(NULL))
}
mydata <- unique(sim.data[,c(id.var, cond.var)])
## if cond.var is non-subject-specific,
## - abs.sum or abs.sum^2
if (nrow(mydata) != length(unique(mydata[[id.var]])))
{
mydata[[cond.var]] <- abs(mydata[[cond.var]])
mean.tmp <- tapply(mydata[[cond.var]], list(mydata[[id.var]]), mean, simplify=TRUE, na.rm=TRUE)
mydata <- data.frame(unique(mydata[[id.var]]), mean.tmp)
colnames(mydata) <- c(id.var, cond.var)
}
## since it is cdd file, some ids are deleted;
## to get same length for original data, we add NA to position of deleted IDs
delete.id <- which(!(unique(total.id) %in% unique(mydata[[id.var]])))
if (length(delete.id) > 0)
{
v.delete.id <<- c(v.delete.id, delete.id)
delete.id.df <- data.frame(delete.id, rep(NA, length(delete.id)))
colnames(delete.id.df) <- colnames(mydata)
mydata <- rbind(mydata, delete.id.df)
}
mydata <- mydata[order(mydata[[id.var]]),]
}
else
{
ErrorMessage(paste("In simulation folder - ", target.dir[i], ", there is NO such NONMEM result file!", sep=""))
return(invisible(NULL))
}
thisName <- paste(rowLabel, i, sep="")
final.df[[thisName]] <<- mydata[[cond.var]]
return(invisible(NULL))
})
}
return(list(data=final.df, deleteID=v.delete.id))
}
extractBootData <- function(dir.path, folder.name, file.name, id.var, cond.var, bootKey.table, totalID, missingIDValue)
{
final.df <- NULL
old.pwd <- getwd()
on.exit(setwd(old.pwd))
try1 <- try(setwd(dir.path), silent=TRUE)
if (inherits(try1, "try-error"))
{
ErrorMessage("Path is wrong! Please input right path.")
return(invisible(NULL))
}
else
{
real.dir <- dir(pattern=folder.name)
if (length(real.dir) < 1)
{
ErrorMessage(paste("There is no folder named as",folder.name, sep=" "))
return(invisible(NULL))
}
target.dir <- gsub(folder.name, "", real.dir)
target.dir <- order(target.dir)
sapply(1:length(target.dir), function(i)
{
real.dir <- paste(folder.name, target.dir, sep="")
if (file.name %in% list.files(path=real.dir[i]))
{
fileName <- paste(real.dir[i], file.name, sep="/")
sim.data <- read.table(fileName, header=T, skip=1)
if (!all(c(id.var, cond.var) %in% colnames(sim.data)))
{
ErrorMessage(paste("In simulation folder - ", real.dir[i], ", Patiend ID or Plot variable
does not match the NONMEM result file !", sep=""))
return(invisible(NULL))
}
if (is.null(bootKey.table))
{
mydata0 <- unique(sim.data[,c(id.var, cond.var)])
}
else
{
mydata0 <- data.frame(rep(as.integer(bootKey.table[i,]), each=nrow(sim.data)/ncol(bootKey.table)), sim.data[,c(cond.var)])
colnames(mydata0) <- c(id.var, cond.var)
}
mydata <- unique(mydata0)
## if cond.var is non-subject-specific: some subject ID matches more than value
## - abs.sum or abs.sum^2
if (nrow(mydata) != length(unique(mydata[[id.var]])))
{
mydata[[cond.var]] <- abs(mydata[[cond.var]])
mean.tmp <- tapply(mydata[[cond.var]], list(mydata[[id.var]]), mean, simplify=TRUE, na.rm=TRUE)
mydata <- data.frame(unique(mydata[[id.var]]), mean.tmp)
colnames(mydata) <- c(id.var, cond.var)
}
## FOR unbootstrap ID
delete.id <- which(! (c(totalID) %in% as.integer(bootKey.table[i,])))
if (missingIDValue == 0) delete.mydata <- data.frame(delete.id, rep(0, length(delete.id)))
else delete.mydata <- data.frame(delete.id, rep(NA, length(delete.id)))
colnames(delete.mydata) <- c(id.var, cond.var)
mydata <- rbind(mydata, delete.mydata)
mydata <- mydata[order(mydata[[id.var]]),]
}
else
{
ErrorMessage(paste("In simulation folder - ", real.dir[i], ", there is NO such NONMEM result file!", sep=""))
return(invisible(NULL))
}
rowLabel <- "resample"
thisName <- paste(rowLabel, i, sep="")
final.df[[thisName]] <<- mydata[[cond.var]]
return(invisible(NULL))
})
}
return(final.df)
}
################################################################################
# Dialog, Table selection for dataset
################################################################################
# labelMessage1 <- "Please move data for diagnostics from left TABLE to right TABLE."
# labelMessage2 <- "After choosing data, click to interactive diagnostics."
# winTitle <- "Configure datasets"
# statusMessage <- "Data is ready for interactive diagnostics."
# menuOption: 1 for model comparison; 2 for interactive graphics
selectDataDialog <- function(winTitle, labelMessage1, labelMessage2, statusMessage, menuOption)
{
# check data exist
if(!checkDataExist())
{
gmessage("No data is available!",
icon=c("warning"), title="Warning")
return(invisible(NULL))
}
alldata.name <- getTotalDataName()
ggobi.gwin <- gwindow(title=winTitle)
ggobi.group <- ggroup(cont=ggobi.gwin, horizontal=FALSE)
g0 <- glabel(text=labelMessage1, cont=ggobi.group)
g1 <- gframe(cont=ggobi.group)
size(g1) <- c(getSubWidth()*0.5, getSubHeight()*0.5)
#tbl1 = gtable(data.frame(AllData=alldata.name), cont = g1, expand=TRUE)
tbl1 = gtable(alldata.name, cont = g1, expand=TRUE)
size(tbl1) <- c(getSubWidth()*0.2, getSubHeight()*0.4)
arrowButton = gbutton(">", cont = g1);
enabled(arrowButton) <- FALSE
#tbl2 = gtable(data.frame(TargetData=colnames(Theoph)), cont=g1, expand = TRUE)
tbl2 = gtable(colnames(Theoph), cont=g1, expand = TRUE)
tbl2[] <- c() ## clear out initialized values. Can't start gtable empty.
size(tbl2) <- c(getSubWidth()*0.2, getSubHeight()*0.4)
g3 <- glabel(text=labelMessage2, cont=ggobi.group)
confirmButton = gbutton("Go to next step", cont= ggobi.group)
addHandlerClicked(tbl1, function(h,...)
{
enabled(arrowButton) <- TRUE
svalue(arrowButton) <- ">"
## no means to clear all selections
})
addHandlerClicked(tbl2, function(h,...)
{
enabled(arrowButton) <- TRUE
svalue(arrowButton) <- "<"
})
addHandlerClicked(arrowButton, function(h,...)
{
if(svalue(arrowButton) == ">") {
curVal = svalue(tbl1)
tbl1[] <- setdiff(tbl1[], curVal)
if(any(is.na(tbl2[])))
tbl2[] <- curVal
else
tbl2[] <- sort(unique(c(tbl2[],curVal))) # adjust for initial NA
} else {
curVal = svalue(tbl2)
tbl2[] <- setdiff(tbl2[], curVal)
tbl1[] <- sort(unique(c(tbl1[],curVal)))
}
enabled(arrowButton) <- FALSE
})
addHandlerClicked(confirmButton, function(h,...)
{
it.data <- tbl2[]
if(length(it.data)==0)
{
ErrorMessage("Please use button in the middle to choose data from left column")
return(invisible(NULL))
}
if (menuOption==2)
{
# for interactive
setItDataName(it.data)
}
else
{
# for model comparison
if (length(it.data)!=2)
{
ErrorMessage("You need to pick TWO datasets for comparison!")
return(invisible(NULL))
}
setComDataName(it.data)
}
svalue(pmg.statusBar) <- statusMessage
dispose(ggobi.gwin)
})
}
subset.f1 <- function(sid, ssign, svalue, tmp.data)
{
check.value <- c(VarName=sid, Sign=ssign, Value=svalue)
## check data exist or not
if (any(check.value==""))
{
ErrorMessage(paste(names(check.value[check.value==""]), " is Not chosen!", sep=""))
}
## TODO: diff numerical value vs categorical value
#check.value[3] <- as.numeric(check.value[3])
if (check.value[2]=="==")
{
tmp1.data <- tmp.data[tmp.data[[check.value[1]]] == check.value[3],]
}
else if (check.value[2]==">")
{
tmp1.data <- tmp.data[tmp.data[[check.value[1]]] > as.numeric(check.value[3]),]
}
else if (check.value[2]==">=")
{
tmp1.data <- tmp.data[tmp.data[[check.value[1]]] >= as.numeric(check.value[3]),]
}
else if (check.value[2]=="<")
{
tmp1.data <- tmp.data[tmp.data[[check.value[1]]] < as.numeric(check.value[3]),]
}
else if (check.value[2]=="<=")
{
tmp1.data <- tmp.data[tmp.data[[check.value[1]]] <= as.numeric(check.value[3]),]
}
else if (check.value[2]=="!=")
{
tmp1.data <- tmp.data[tmp.data[[check.value[1]]] != check.value[3],]
}
return(tmp1.data)
}
subset.okButtonHandler = function(., h,...)
{
subset.var <- svalue(.$table.widget)
dispose(.$window)
if (length(subset.var) < 1)
{
ErrorMessage("No data is chosen for subset!")
return(invisible(NULL))
}
gwin.subset = gwindow("Subset")
gframe.subset = gframe(text = "Subset", markup = FALSE, pos = 0, horizontal=FALSE, container = gwin.subset)
tbl = glayout(cont=gframe.subset)
tbl.value <- list()
currentPage <- svalue(pmg.dialog.notebook)
currentData <- getCurrentData(currentPage)
for ( i in 1:length(subset.var))
{
tbl.value[[i*3-2]] = gdroplist(items=subset.var[i])
tbl[i,1] = tbl.value[[i*3-2]]
if (is.factor(currentData[[subset.var[i]]]) || is.character(currentData[[subset.var[i]]]))
tbl.value[[i*3-1]] = gdroplist(items=c("==", "!="))
else
tbl.value[[i*3-1]] = gdroplist(items=c("==", ">", ">=", "<", "<="))
tbl[i,2] = tbl.value[[i*3-1]]
tbl.value[[i*3]] = gedit(text="")
tbl[i,3] = tbl.value[[i*3]]
}
gbutton(text = "Subset", border=TRUE, cont=gframe.subset, handler = function(h,...)
{
sapply(1:length(subset.var), function(i)
{
currentData <<- subset.f1(svalue(tbl.value[[i*3-2]]), svalue(tbl.value[[i*3-1]]),
svalue(tbl.value[[i*3]]), currentData)
})
thisDatano <- getTotalDataLen() + 1
datatype <- "Subset"
thisDataName <- paste(getTotalDataLen() + 1, "_", datatype , sep="")
setDatasets(currentData, thisDatano) # use no as data name
setCurrentDataType(datatype, thisDataName)
ptable=gtable(currentData, multiple=TRUE, expand=TRUE)
pkmain.add(ptable, as.character(thisDataName), override.closebutton = TRUE)
dispose(gwin.subset)
svalue(PKENV$pmg.statusBar) <- "Subset sucessfully!"
})
}
factor.okButtonHandler = function(., h, ...)
{
factor.var <- svalue(.$table.widget)
if (length(factor.var) < 1)
{
ErrorMessage("No variable is chosen!")
return(invisible(NULL))
}
currentPage <- svalue(pmg.dialog.notebook)
currentData <- getCurrentData(currentPage)
factor.call.value <- svalue(.$checkbox.widget)
if (factor.call.value == "factor") factor.call <- "factor"
else if (factor.call.value == "numeric") factor.call <- "as.numeric"
else factor.call <- "as.character"
## factor
sapply(1:length(factor.var), function(i)
{
currentData[[factor.var[i]]] <<- do.call(factor.call, list(currentData[[factor.var[i]]]))
})
thisDataName <- getTotalDataName()[currentPage]
setDatasets(currentData, thisDataName) # use no as data name
# No need to reset data type
#setCurrentDataType(svalue(datatype), thisDataName)
svalue(pmg.statusBar) <- "Factor/Unfactor sucessfully!"
dispose(.$window)
}
saveImageHandler = function(.,h,...)
{
## check saving format is setup!
if (!checkSaveFormat())
{
ErrorMessage("Please Menu configure to set save format first in main panel!")
return(invisible(NULL))
}
currentMain <- svalue(pmg.dialog.notebook)
currentPage <- svalue(pk.dialog.notebook)
pkcode <- getPKCode(currentPage)
## datagroup: data, boot, outlier
# datagroup = 0, save single plot; otherwise, multiple plot
# specialPlot, TRUE, - data, using others; otherwise, use getCurrentData()
if (.$datagroup == 0)
{
# check data absolute or not
abs.no <- getNameDataSpecialPlot()
abs.check <- currentPage %in% abs.no
if (currentPage %in% abs.no) pkcode$pklist$data <- getDataSpecialPlot(as.character(currentPage))
else pkcode$pklist$data <- getCurrentData(currentMain)
}
else pkcode$pklist$data <- getValidateData()
saveFormat <- getSaveFormat()
gfile("Save file",type="save", handler = function(h,...)
{
mycommand <- saveFormat$command
sapply(1:length(mycommand), function(i)
{
# figureGroup: save one file or multiple file
if (.$figureGroup == 0)
{
layout.plot <- getDataLayoutPlot()
if (currentPage %in% layout.plot) filename <- paste(h$file, "%3d.", mycommand[i], sep="")
else filename <- paste(h$file, mycommand[i], sep=".")
}
else
filename <- paste(h$file, "%3d.", mycommand[i], sep="")
if (!is.na(saveFormat$width) && !is.na(saveFormat$width))
mysavelist <- list(file=filename, width=saveFormat$width, height=saveFormat$height)
else
mysavelist <- list(file=filename)
do.call(mycommand[i], mysavelist)
print(pkcode$pklist)
dev.off()
})
focus(.$window) <- TRUE
})
}
saveImageHandler.pkmodel = function(.,h,...)
{
## check saving format is setup!
if (!checkSaveFormat())
{
ErrorMessage("Please Menu configure to set save format first in main panel!")
return(invisible(NULL))
}
currentMain <- svalue(pmg.dialog.notebook)
currentPage <- svalue(pk.dialog.notebook)
pkcode <- getPKCode(currentPage)
## datagroup: data, boot, outlier
# datagroup = 0, save single plot; otherwise, multiple plot
# specialPlot, TRUE, - data, using others; otherwise, use getCurrentData()
if (.$datagroup == 0)
{
mydata <- getPKGGobi(currentPage)
x.name <- mydata$x
if ((length(x.name) > 1) && (svalue(.$savewd[["graphics"]]) != "lattice"))
{
## for scatterplot matrix, do nothing
}
else
{
# check data absolute or not
abs.no <- getNameDataSpecialPlot()
abs.check <- currentPage %in% abs.no
if (currentPage %in% abs.no) pkcode$pklist$data <- getDataSpecialPlot(as.character(currentPage))
else pkcode$pklist$data <- getCurrentData(currentMain)
}
}
else pkcode$pklist$data <- getValidateData()
saveFormat <- getSaveFormat()
gfile("Save file",type="save", handler = function(h,...)
{
mycommand <- saveFormat$command
sapply(1:length(mycommand), function(i)
{
# figureGroup: save one file or multiple file
if (.$figureGroup == 0)
{
layout.plot <- getDataLayoutPlot()
if (currentPage %in% layout.plot) filename <- paste(h$file, "%3d.", mycommand[i], sep="")
else filename <- paste(h$file, mycommand[i], sep=".")
}
else
filename <- paste(h$file, "%3d.", mycommand[i], sep="")
if (!is.na(saveFormat$width) && !is.na(saveFormat$width))
mysavelist <- list(file=filename, width=saveFormat$width, height=saveFormat$height)
else
mysavelist <- list(file=filename)
do.call(mycommand[i], mysavelist)
print(pkcode$pklist)
dev.off()
})
focus(.$window) <- TRUE
})
}
saveImageHandler.matrix = function(.,h,...)
{
## check saving format is setup!
if (!checkSaveFormat())
{
ErrorMessage("Please Menu configure to set save format first in main panel!")
return(invisible(NULL))
}
currentMain <- svalue(pmg.dialog.notebook)
currentPage <- svalue(pk.dialog.notebook)
pkcode <- getPKCode(currentPage)
## datagroup: data, boot, outlier
# datagroup = 0, save single plot; otherwise, multiple plot
# specialPlot, TRUE, - data, using others; otherwise, use getCurrentData()
if (.$datagroup == 0)
{
# THAT'S SPECIAL PART FOR ggplot2::plotmatrix. No need to replace data
if (svalue(.$savewd[["graphics"]]) == "lattice")
{
abs.no <- getNameDataSpecialPlot()
abs.check <- currentPage %in% abs.no
if (currentPage %in% abs.no) pkcode$pklist$data <- getDataSpecialPlot(as.character(currentPage))
else pkcode$pklist$data <- getCurrentData(currentMain)
}
}
else pkcode$pklist$data <- getValidateData()
saveFormat <- getSaveFormat()
gfile("Save file",type="save", handler = function(h,...)
{
mycommand <- saveFormat$command
sapply(1:length(mycommand), function(i)
{
# figureGroup: save one file or multiple file
if (.$figureGroup == 0)
{
layout.plot <- getDataLayoutPlot()
if (currentPage %in% layout.plot) filename <- paste(h$file, "%3d.", mycommand[i], sep="")
else filename <- paste(h$file, mycommand[i], sep=".")
}
else
filename <- paste(h$file, "%3d.", mycommand[i], sep="")
if (!is.na(saveFormat$width) && !is.na(saveFormat$width))
mysavelist <- list(file=filename, width=saveFormat$width, height=saveFormat$height)
else
mysavelist <- list(file=filename)
do.call(mycommand[i], mysavelist)
print(pkcode$pklist)
dev.off()
})
focus(.$window) <- TRUE
})
}
model.ggobiImageHandler = function(.,h,...)
{
# get ggobi <-> pk.dialog page: variable list
currentPage <- svalue(pk.dialog.notebook)
if (currentPage == 0)
{
ErrorMessage("Please draw figure first!")
return(NULL)
}
mydata <- getPKGGobi(currentPage)
# check data absolute or not
abs.no <- getNameDataSpecialPlot()
currentMain <- svalue(pmg.dialog.notebook)
if (is.null(abs.no)) tmp.data <- getCurrentData(currentMain)
else
{
abs.check <- currentPage %in% abs.no
if (currentPage %in% abs.no) tmp.data <- getDataSpecialPlot(as.character(currentPage))
else tmp.data <- getCurrentData()
}
x.name <- mydata$x
y.name <- mydata$y
if (is.null(y.name))
{
g <- ggobi(tmp.data)
if (length(x.name) == 1)
{
display(g[1], pmode="Barchart", vars=list(X = mydata$x))
}
else # for scatterplot matrix
{
display(g[1], "Scatterplot Matrix", vars=list(X = mydata$x) )
}
}
else
{
x.ind <- which(colnames(tmp.data)== x.name)
y.ind <- which(colnames(tmp.data)== y.name)
old.ind <- c(1:length(colnames(tmp.data)))
old.ind <- old.ind[-c(x.ind, y.ind)]
tmp.data <- tmp.data[c(x.ind, y.ind, old.ind)]
g <- ggobi(tmp.data)
}
}
validation.ggobiImageHandler = function(.,h,...)
{
# get ggobi <-> pk.dialog page: variable list
currentPage <- svalue(pk.dialog.notebook)
if (currentPage == 0)
{
ErrorMessage("Please draw figure first!")
return(NULL)
}
mydata <- getPKGGobi(currentPage)$x
g <- ggobi(mydata)
display(g[1], "Parallel Coordinates Display")
}
psn.outlier.ggobiImageHandler = function(.,h,...)
{
ErrorMessage("No ggobi instance available for this data.")
}
vis.outlier.ggobiImageHandler = function(.,h,...)
{
currentPage <- length(getNameDataSpecialPlot()) # new
if (currentPage == 0)
{
ErrorMessage("Please draw figure first!")
return(NULL)
}
id.var <- svalue(.$widgets[["Patient ID:"]])
mydata <- getDataSpecialPlot(as.character(currentPage))
# make it factor, so can link all together
mydata[[id.var]] <- factor(mydata[[id.var]])
currentMain <- svalue(pmg.dialog.notebook)
oridata <- getCurrentData(currentMain)
oridata[[id.var]] <- factor(oridata[[id.var]])
# replace name, so that all plots have same ID name to link
oriname <- colnames(oridata)
if (id.var %in% oriname)
{
oriname <- gsub(id.var, "resampleID", oriname)
colnames(oridata) <- oriname
}
Time.name <- getGGobiPlotType(as.character(currentMain))$Time
Conc.name <- getGGobiPlotType(as.character(currentMain))$Conc
ID.name <- getGGobiPlotType(as.character(currentMain))$ID
if (length(Time.name)==0 || length(Conc.name)==0 || length(ID.name)==0)
{
ErrorMessage("Please make sure the input file type is PK data!")
return(invisible(NULL))
}
Time.ind <- which(colnames(oridata)==Time.name)
Conc.ind <- which(colnames(oridata)==Conc.name)
oridata <- cbind(oridata[,c(Time.ind, Conc.ind)], oridata[,-c(Time.ind, Conc.ind)])
gtext <- paste("ggobi_longitudinal(oridata,", Time.name, ", resampleID)", sep="")
g <- eval(parse(text=gtext))
# not g[2], because the edges of longitudinal data is g[2]
g["moreplot"] <- mydata
display(g[3], pmode="Scatterplot Display",
vars=list(X="cor1", Y="cor2"))
display(g[3], pmode="Scatterplot Display",
vars=list(X="resampleID", Y="para"))
}
boot.vis.ggobiImageHandler = function(.,h,...)
{
currentPage <- length(getNameDataSpecialPlot())
if (currentPage == 0)
{
ErrorMessage("Please draw figure first!")
return(NULL)
}
id.var <- svalue(.$widgets[["Patient ID:"]])
mydata <- getDataSpecialPlot(as.character(currentPage))
# make it factor, so can link all together
mydata[[id.var]] <- factor(mydata[[id.var]])
currentMain <- svalue(pmg.dialog.notebook)
oridata <- getCurrentData(currentMain)
Time.name <- getGGobiPlotType(as.character(currentMain))$Time
Conc.name <- getGGobiPlotType(as.character(currentMain))$Conc
ID.name <- getGGobiPlotType(as.character(currentMain))$ID
if (length(Time.name)==0 || length(Conc.name)==0 || length(ID.name)==0)
{
ErrorMessage("Please make sure the input file type is PK data!")
return(invisible(NULL))
}
Time.ind <- which(colnames(oridata)==Time.name)
Conc.ind <- which(colnames(oridata)==Conc.name)
oridata <- cbind(oridata[,c(Time.ind, Conc.ind)], oridata[,-c(Time.ind, Conc.ind)])
oridata[[id.var]] <- factor(oridata[[id.var]])
gtext <- paste("ggobi_longitudinal(oridata,", Time.name, ",", ID.name, ")", sep="")
g <- eval(parse(text=gtext))
g["moreplot"] <- mydata
# not g[2], because the edges of longitudinal data is g[2]
display(g[3], pmode="Scatterplot Display",
vars=list(X="ID", Y="VAR"))
}
getHistCall <- function(hist.graphics, hist.x,
hist.bin,
hist.main,
hist.xlab,
hist.ylab,
hist.type,
hist.cond,
hist.layout_x,
hist.layout_y,
hist.data
)
{
hist.col <- getFigConfig()$col
currentMain <- svalue(pmg.dialog.notebook)
if (missing(hist.data)) hist.data <- getCurrentData(currentMain)
if (hist.graphics == "lattice")
{
x <- paste( "~", hist.x, sep="")
if ( !is.null(hist.bin) && hist.bin != "" )
{
if ( hist.cond == "")
{
x <- as.formula(x)
lattice.final <- histogram(x=x, xlab=hist.xlab, nint = as.numeric(hist.bin),
ylab=hist.ylab, type= hist.type, col=hist.col,
main=hist.main , data= hist.data )
}
else
{
x <- as.formula(paste(x, "|", hist.cond, sep=" "))
lattice.layout <- as.numeric(c(hist.layout_x, hist.layout_y))
lattice.final <- histogram(x=x, xlab=hist.xlab, nint = as.numeric(hist.bin),
ylab=hist.ylab, type= hist.type, col=hist.col,
layout = lattice.layout,
main=hist.main , data= hist.data)
}
}
else
{
if ( is.null(hist.cond) || hist.cond =="" )
{
x <- as.formula(x)
lattice.final <- histogram(x=x, xlab=hist.xlab,
ylab=hist.ylab, type= hist.type, col=hist.col,
main=hist.main , data= hist.data)
}
else
{
x <- as.formula(paste(x, "|", hist.cond, sep=" "))
lattice.layout <- as.numeric(c(hist.layout_x, hist.layout_y))
lattice.final <- histogram(x=x, xlab=hist.xlab,
ylab=hist.ylab, type= hist.type, col=hist.col,
layout = lattice.layout,
main=hist.main , data= hist.data)
}
}
return(lattice.final)
}
else ## start ggplot2
{
mytype <- switch(hist.type,
#p = c("point"),
#l = c("line"),
# b = c("point", "smooth"),
#psmooth = c("point", "smooth"),
#lsmooth = c("line", "smooth"),
percent = c("histogram"),
count = c("histogram"),
density = c("histogram"),
c("histogram")
)
myx <- hist.data[[hist.x]]
if ( !is.null(hist.bin) && hist.bin != "" )
{
checkbin <- 1
f <- as.numeric(diff(range(myx)/as.numeric(hist.bin)))
}
else checkbin <- 0
if ( !is.null(hist.cond) && hist.cond != "" )
{
checkcond <- 1
if (hist.layout_x == "" || hist.layout_y == "")
{
ErrorMessage("layout_x or layout_y is NOT specified for conditional variable")
return(invisible(NULL))
}
mycond <- hist.data[[hist.cond]]
total.figno <- as.numeric(hist.layout_x) * as.numeric(hist.layout_y)
if (length(unique(mycond)) > total.figno)
{
newno <- unique(mycond)[1:total.figno]
part.data <- hist.data[which(mycond%in%newno),]
}
else part.data <- hist.data
}
else checkcond <- 0
if (checkcond == 1)
{
if (checkbin == 1)
{
ggplot.final <- qplot(x=myx, xlab=hist.xlab,
ylab=hist.ylab, #colour = hist.col,
main=hist.main, data=hist.data)+ geom_histogram(binwidth = f)+ facet_wrap(hist.cond, ncol = as.numeric(hist.layout_x))
}
else
{
ggplot.final <- qplot(x=myx, xlab=hist.xlab,
ylab=hist.ylab, geom = mytype, #colour = hist.col,
main=hist.main, data=hist.data)+ facet_wrap(hist.cond, ncol = as.numeric(hist.layout_x))
}
}
else
{
if (checkbin == 1)
{
ggplot.final <- qplot(x=myx, xlab=hist.xlab,
ylab=hist.ylab, #colour = hist.col,
main=hist.main, data=hist.data) + geom_histogram(binwidth = f)
}
else
{
ggplot.final <- qplot(x=myx, xlab=hist.xlab,
ylab=hist.ylab, geom = mytype, #colour = hist.col,
main=hist.main, data=hist.data)
}
}
return(ggplot.final)
}
}
getScatterCall <- function(hist.graphics, hist.x, hist.y,
hist.main,
hist.xlab,
hist.ylab,
hist.type,
hist.cond,
hist.layout_x,
hist.layout_y, hist.data
)
{
currentMain <- svalue(pmg.dialog.notebook)
if (missing(hist.data)) hist.data <- getCurrentData(currentMain)
hist.col <- getFigConfig()$col
if ((missing(hist.type)) || hist.type=="") hist.type = "p"
if (!is.null(getFigConfig()$loess) && getFigConfig()$loess == 1) hist.type = c(hist.type, "smooth")
## two graph packages
if (hist.graphics == "lattice")
{
x <- paste(hist.y, "~", hist.x, sep="")
if ( hist.cond == "")
{
x <- as.formula(x)
lattice.final <- xyplot(x=x, xlab=hist.xlab,
ylab=hist.ylab, type= hist.type, col=hist.col,
main=hist.main , data= hist.data)
## type: ts
if (hist.type == "ts" && (!is.null(getGGobiPlotType(currentMain)$ID)) )
{
lattice.final <- xyplot(x=x, xlab=hist.xlab, ylab=hist.ylab,
type=c("l","p"), groups= hist.data[,getGGobiPlotType(currentMain)$ID],
main=hist.main , data= hist.data)
}
}
else
{
x <- as.formula(paste(x, "|", hist.cond, sep=" "))
lattice.layout <- as.numeric(c(hist.layout_x, hist.layout_y))
lattice.final <- xyplot(x=x, xlab=hist.xlab,
ylab=hist.ylab, type= hist.type, col=hist.col,
layout = lattice.layout,
main=hist.main , data= hist.data)
## type: ts
if (hist.type == "ts" && (!is.null(getGGobiPlotType(currentMain)$ID)) )
{
lattice.final <- xyplot(x=x, xlab=hist.xlab, ylab=hist.ylab,
type=c("l","p"), groups= hist.data[,getGGobiPlotType(currentMain)$ID],
layout = lattice.layout,
main=hist.main , data= hist.data)
}
}
return(lattice.final)
}
else ## start ggplot
{
tmp.type <- NULL
if (length(hist.type) > 1)
{
tmp.type <- hist.type
hist.type <- hist.type[1]
}
hist.type <- switch(hist.type,
p = c("point"),
l = c("line"),
b = c("point", "line"),
ts = c("ts"),
#psmooth = c("point", "smooth"),
#lsmooth = c("line", "smooth"),
a = c("point", "line"),
percent = c("histogram"),
count = c("histogram"),
density = c("histogram")
)
if (!is.null(tmp.type)) hist.type <- c(hist.type, tmp.type[-1])
myx <- hist.data[[hist.x]]
myy <- hist.data[[hist.y]]
if ( !is.null(hist.cond) && hist.cond != "" )
{
# TODO
if (hist.layout_x == "" || hist.layout_y == "")
{
ErrorMessage("layout_x or layout_y is NOT specified for conditional variable")
return(invisible(NULL))
}
mycond <- hist.data[[hist.cond]]
total.figno <- as.numeric(hist.layout_x) * as.numeric(hist.layout_y)
if (length(unique(mycond)) > total.figno)
{
newno <- unique(mycond)[1:total.figno]
part.data <- hist.data[which(mycond%in%newno),]
}
else part.data <- hist.data
## type: ts
if (hist.type == "ts" && (!is.null(getGGobiPlotType(currentMain)$ID)) )
{
ggplot.final <- qplot(x=myx, y=myy, xlab=hist.xlab, ylab=hist.ylab,
geom = c("point", "line"), colour = part.data[,getGGobiPlotType(currentMain)$ID],
main=hist.main , data= part.data, se=F) + facet_wrap(hist.cond, ncol = as.numeric(hist.layout_x)) + opts(legend.position="none")
}
else
{
ggplot.final <- qplot(x=myx, y=myy, xlab=hist.xlab,
ylab=hist.ylab, geom = hist.type, #colour = hist.col,
main=hist.main , data= part.data, se=F) + facet_wrap(hist.cond, ncol = as.numeric(hist.layout_x))
}
}
else
{
if (hist.type == "ts" && (!is.null(getGGobiPlotType(currentMain)$ID)) )
{
ggplot.final <- qplot(x=myx, y=myy, xlab=hist.xlab, ylab=hist.ylab,
geom = c("point", "line"), colour = hist.data[,getGGobiPlotType(currentMain)$ID],
main=hist.main , data= hist.data, se=F) + opts(legend.position="none")
}
else
{
ggplot.final <- qplot(x=myx, y=myy, xlab=hist.xlab,
ylab=hist.ylab, geom = hist.type, #colour = hist.col,
main=hist.main , data= hist.data, se=F)
}
}
return(ggplot.final)
}
}
getScatterCall.back <- function(hist.graphics, hist.x, hist.y,
hist.main,
hist.xlab,
hist.ylab,
hist.type,
hist.cond,
hist.layout_x,
hist.layout_y, hist.data
)
{
currentMain <- svalue(pmg.dialog.notebook)
if (missing(hist.data)) hist.data <- getCurrentData(currentMain)
hist.col <- getFigConfig()$col
if (hist.type == "")
{
if (is.null(getFigConfig()$loess)) hist.type = "p"
else if (getFigConfig()$loess == 1) hist.type = c("p", "smooth")
else
{
ErrorMessage("Wrong with loess options!")
return(invisible(NULL))
}
}
## two graph packages
if (hist.graphics == "lattice")
{
x <- paste(hist.y, "~", hist.x, sep="")
if ( hist.cond == "")
{
x <- as.formula(x)
lattice.final <- xyplot(x=x, xlab=hist.xlab,
ylab=hist.ylab, type= hist.type, col=hist.col,
main=hist.main , data= hist.data)
}
else
{
x <- as.formula(paste(x, "|", hist.cond, sep=" "))
lattice.layout <- as.numeric(c(hist.layout_x, hist.layout_y))
lattice.final <- xyplot(x=x, xlab=hist.xlab,
ylab=hist.ylab, type= hist.type, col=hist.col,
layout = lattice.layout,
main=hist.main , data= hist.data)
}
return(lattice.final)
}
else ## start ggplot
{
hist.type <- switch(hist.type,
p = c("point"),
l = c("line"),
b = c("point", "line"),
#psmooth = c("point", "smooth"),
#lsmooth = c("line", "smooth"),
percent = c("histogram"),
count = c("histogram"),
density = c("histogram")
)
myx <- hist.data[[hist.x]]
myy <- hist.data[[hist.y]]
if ( !is.null(hist.cond) && hist.cond != "" )
{
# TODO
if (hist.layout_x == "" || hist.layout_y == "")
{
ErrorMessage("layout_x or layout_y is NOT specified for conditional variable")
return(invisible(NULL))
}
mycond <- hist.data[[hist.cond]]
total.figno <- as.numeric(hist.layout_x) * as.numeric(hist.layout_y)
if (length(unique(mycond)) > total.figno)
{
newno <- unique(mycond)[1:total.figno]
part.data <- hist.data[which(mycond%in%newno),]
}
else part.data <- hist.data
ggplot.final <- qplot(x=myx, y=myy, xlab=hist.xlab,
ylab=hist.ylab, geom = hist.type, #colour = hist.col,
main=hist.main , data= part.data) + facet_wrap(hist.cond, ncol = as.numeric(hist.layout_x))
}
else
{
ggplot.final <- qplot(x=myx, y=myy, xlab=hist.xlab,
ylab=hist.ylab, geom = hist.type, #colour = hist.col,
main=hist.main , data= hist.data)
}
return(ggplot.final)
}
}
getPKHistCall <- function(hist.graphics, hist.x,
hist.bin,
hist.main,
hist.xlab,
hist.ylab,
hist.type,
hist.cond,
hist.layout_x,
hist.layout_y,
hist.data
)
{
hist.col <- getFigConfig()$col
if (missing(hist.data)) hist.data <- getCurrentData()
if (missing(hist.type) || hist.type == "") hist.type <- "percent"
if (hist.graphics == "lattice")
{
x <- paste( "~", hist.x, sep="")
if ( !is.null(hist.bin) && hist.bin != "" )
{
if ( hist.cond == "")
{
x <- as.formula(x)
lattice.final <- histogram(x=x, xlab=hist.xlab, nint = as.numeric(hist.bin),
ylab=hist.ylab, type= hist.type, col=hist.col,
main=hist.main , data= hist.data)
}
else
{
x <- as.formula(paste(x, "|", hist.cond, sep=" "))
lattice.layout <- as.numeric(c(hist.layout_x, hist.layout_y))
lattice.final <- histogram(x=x, xlab=hist.xlab, nint = as.numeric(hist.bin),
ylab=hist.ylab, type= hist.type, col=hist.col,
layout = lattice.layout,
main=hist.main , data= hist.data)
}
}
else
{
if ( is.null(hist.cond) || hist.cond =="" )
{
x <- as.formula(x)
lattice.final <- histogram(x=x, xlab=hist.xlab,
ylab=hist.ylab, type= hist.type, col=hist.col,
main=hist.main , data= hist.data)
}
else
{
x <- as.formula(paste(x, "|", hist.cond, sep=" "))
lattice.layout <- as.numeric(c(hist.layout_x, hist.layout_y))
lattice.final <- histogram(x=x, xlab=hist.xlab,
ylab=hist.ylab, type= hist.type, col=hist.col,
layout = lattice.layout,
main=hist.main , data= hist.data)
}
}
return(lattice.final)
}
else ## start ggplot2
{
mytype <- switch(hist.type,
#p = c("point"),
#l = c("line"),
#b = c("point", "smooth"),
#psmooth = c("point", "smooth"),
#lsmooth = c("line", "smooth"),
percent = c("histogram"),
count = c("histogram"),
density = c("histogram"),
c("histogram")
)
myx <- hist.data[[hist.x]]
if ( !is.null(hist.bin) && hist.bin != "" )
{
checkbin <- 1
f <- as.numeric(diff(range(myx)/as.numeric(hist.bin)))
}
else checkbin <- 0
if ( !is.null(hist.cond) && hist.cond != "" )
{
checkcond <- 1
if (hist.layout_x == "" || hist.layout_y == "")
{
ErrorMessage("layout_x or layout_y is NOT specified for conditional variable")
return(invisible(NULL))
}
mycond <- hist.data[[hist.cond]]
total.figno <- as.numeric(hist.layout_x) * as.numeric(hist.layout_y)
if (length(unique(mycond)) > total.figno)
{
newno <- unique(mycond)[1:total.figno]
part.data <- hist.data[which(mycond%in%newno),]
}
else part.data <- hist.data
}
else checkcond <- 0
if (checkcond == 1)
{
if (checkbin == 1)
{
ggplot.final <- qplot(x=myx, xlab=hist.xlab,
ylab=hist.ylab, geom = mytype, #colour = hist.col,
main=hist.main , data= part.data)+ geom_histogram(binwidth = f)+ facet_wrap(hist.cond, ncol = as.numeric(hist.layout_x))
}
else
{
ggplot.final <- qplot(x=myx, xlab=hist.xlab,
ylab=hist.ylab, geom = mytype, #colour = hist.col,
main=hist.main , data= part.data)+ facet_wrap(hist.cond, ncol = as.numeric(hist.layout_x))
}
}
else
{
if (checkbin == 1)
{
ggplot.final <- qplot(x=myx, xlab=hist.xlab,
ylab=hist.ylab, geom = mytype, #colour = hist.col,
main=hist.main , data= hist.data) + geom_histogram(binwidth = f)
}
else
{
ggplot.final <- qplot(x=myx, xlab=hist.xlab,
ylab=hist.ylab, geom = mytype, #colour = hist.col,
main=hist.main , data= hist.data)
}
}
return(ggplot.final)
}
}
getPKScatterCall <- function(hist.graphics, hist.x, hist.y,
hist.bin,
hist.main,
hist.xlab,
hist.ylab,
hist.type,
hist.cond,
hist.layout_x,
hist.layout_y, hist.data
)
{
if (missing(hist.data)) hist.data <- getCurrentData()
hist.col <- getFigConfig()$col
## two graph packages
if (hist.graphics == "lattice")
{
if (hist.type == "")
{
if (is.null(getFigConfig()$loess)) hist.type = "p"
else if (getFigConfig()$loess == 1) hist.type = c("p", "smooth")
else
{
ErrorMessage("Wrong with loess options!")
return(invisible(NULL))
}
}
x <- paste(hist.y, "~", hist.x, sep="")
if ( hist.cond == "")
{
x <- as.formula(x)
lattice.final <- xyplot(x=x, xlab=hist.xlab,
ylab=hist.ylab, type= hist.type, col=hist.col,
main=hist.main , data= hist.data)
}
else
{
x <- as.formula(paste(x, "|", hist.cond, sep=" "))
lattice.layout <- as.numeric(c(hist.layout_x, hist.layout_y))
lattice.final <- xyplot(x=x, xlab=hist.xlab,
ylab=hist.ylab, type= hist.type, col=hist.col,
layout = lattice.layout,
main=hist.main , data= hist.data)
}
return(lattice.final)
}
else ## start ggplot
{
if (hist.type == "")
{
if (is.null(getFigConfig()$loess)) hist.type = "point"
else if (getFigConfig()$loess == 1) hist.type = c("point", "smooth")
else
{
ErrorMessage("Wrong with loess options!")
return(invisible(NULL))
}
}
myx <- hist.data[[hist.x]]
myy <- hist.data[[hist.y]]
if ( !is.null(hist.cond) && hist.cond != "" )
{
# TODO
if (hist.layout_x == "" || hist.layout_y == "")
{
ErrorMessage("layout_x or layout_y is NOT specified for conditional variable")
return(invisible(NULL))
}
mycond <- hist.data[[hist.cond]]
total.figno <- as.numeric(hist.layout_x) * as.numeric(hist.layout_y)
if (length(unique(mycond)) > total.figno)
{
newno <- unique(mycond)[1:total.figno]
part.data <- hist.data[which(mycond%in%newno),]
}
else part.data <- hist.data
ggplot.final <- qplot(x=myx, y=myy, xlab=hist.xlab,
ylab=hist.ylab, geom = hist.type, #colour = hist.col,
main=hist.main , data= part.data, se=F) + facet_wrap(hist.cond, ncol = as.numeric(hist.layout_x))
}
else
{
ggplot.final <- qplot(x=myx, y=myy, xlab=hist.xlab,
ylab=hist.ylab, geom = hist.type, #colour = hist.col,
main=hist.main , data= hist.data, se=F)
}
return(ggplot.final)
}
}
getPKQqmathCall <- function(hist.graphics, hist.x,
hist.main,
hist.xlab,
hist.ylab,
hist.type,
hist.cond,
hist.layout_x,
hist.layout_y,
hist.data
)
{
hist.col <- getFigConfig()$col
if (missing(hist.data)) hist.data <- getCurrentData()
if (hist.graphics == "lattice")
{
x <- paste( "~", hist.x, sep="")
if (hist.type == "")
{
if (is.null(getFigConfig()$loess)) hist.type = "p"
else if (getFigConfig()$loess == 1) hist.type = c("p", "smooth")
else
{
ErrorMessage("Wrong with loess options!")
return(invisible(NULL))
}
}
if ( is.null(hist.cond) || hist.cond =="" )
{
x <- as.formula(x)
lattice.final <- qqmath(x=x, xlab=hist.xlab,
ylab=hist.ylab, type= hist.type, col=hist.col,
main=hist.main , data= hist.data)
}
else
{
x <- as.formula(paste(x, "|", hist.cond, sep=" "))
lattice.layout <- as.numeric(c(hist.layout_x, hist.layout_y))
lattice.final <- qqmath(x=x, xlab=hist.xlab,
ylab=hist.ylab, type= hist.type, col=hist.col,
layout = lattice.layout,
main=hist.main , data= hist.data)
}
return(lattice.final)
}
else ## start ggplot2
{
ggplot.text <- paste("ggplot(hist.data) + geom_point(aes(sample =", hist.x, "), stat = \"qq\")", sep="")
ggplot.final <- eval(parse(text=ggplot.text))
return(ggplot.final)
}
}
getPKBwplotCall <- function(hist.graphics, hist.x, hist.y,
hist.bin,
hist.main,
hist.xlab,
hist.ylab,
hist.type,
hist.cond,
hist.layout_x,
hist.layout_y, hist.data
)
{
if (missing(hist.data)) hist.data <- getCurrentData()
hist.col <- getFigConfig()$col
## two graph packages
if (hist.graphics == "lattice")
{
if (is.null(getFigConfig()$loess)) hist.type = "p"
else if (getFigConfig()$loess == 1) hist.type = c("p", "smooth")
else
{
ErrorMessage("Wrong with loess options!")
return(invisible(NULL))
}
x <- paste(hist.y, "~", hist.x, sep="")
if ( hist.cond == "")
{
x <- as.formula(x)
lattice.final <- bwplot(x=x, xlab=hist.xlab,
ylab=hist.ylab, type= hist.type, col=hist.col,
main=hist.main , data= hist.data)
}
else
{
x <- as.formula(paste(x, "|", hist.cond, sep=" "))
lattice.layout <- as.numeric(c(hist.layout_x, hist.layout_y))
lattice.final <- bwplot(x=x, xlab=hist.xlab,
ylab=hist.ylab, type= hist.type, col=hist.col,
layout = lattice.layout,
main=hist.main , data= hist.data)
}
return(lattice.final)
}
else ## start ggplot
{
if (hist.type == "")
{
if (is.null(getFigConfig()$loess)) hist.type = "point"
else if (getFigConfig()$loess == 1) hist.type = c("point", "smooth")
else
{
ErrorMessage("Wrong with loess options!")
return(invisible(NULL))
}
}
myx <- hist.data[[hist.x]]
myy <- hist.data[[hist.y]]
tmp1 <- paste("ggplot(hist.data, aes(factor(", hist.x, "),", hist.y, sep="")
tmp2 <- paste(")) + geom_boxplot() +", "labs(x=hist.xlab, y=hist.ylab)", sep="")
ggplot.final <- eval(parse(text=paste(tmp1, tmp2, sep="")))
if ( !is.null(hist.cond) && hist.cond != "" )
{
# TODO
if (hist.layout_x != "" )
ggplot.final <- ggplot.final + facet_wrap(hist.cond, ncol = as.numeric(hist.layout_x))
else if (hist.layout_y != "")
ggplot.final <- ggplot.final + facet_wrap(hist.cond, nrow = as.numeric(hist.layout_y))
else
{
ErrorMessage("No layout is specified for conditional variable")
return(invisible(NULL))
}
}
return(ggplot.final)
}
}
getPKMatrixplotCall <- function(hist.graphics, hist.data)
{
currentMain <- svalue(pmg.dialog.notebook)
if (missing(hist.data)) hist.data <- getCurrentData(currentMain)
hist.col <- getFigConfig()$col
## two graph packages
if (hist.graphics == "lattice")
{
lattice.final <- splom(hist.data)
return(lattice.final)
}
else ## start ggplot
{
ggplot.final <- plotmatrix(hist.data)
return(ggplot.final)
}
}
################################################################################
################################################################################
#getSubHeight() = 500
#getSubWidth() = 800
#size(pmg.dialog.notebook) <- c(getSubWidth()*0.6,getSubHeight()*.67)
################################################################################
cleanFigureButtonHandler = function(.,h,...) #1031
{
# clean code from other window
cleanPKCode()
cleanPKGGobi()
cleanDataSpecialPlot()
for(i in 1:length(pk.dialog.notebook))
dispose(pk.dialog.notebook)
}
summary.uni.okButtonHandler = function(.,h,...)
{
tmp.para <- NULL
pgraph = ggraphics(ps=6)
size(pgraph) <- c(getSubHeight()*0.5, getSubWidth()*0.5)
add(pk.dialog.notebook, pgraph, label = message,
override.closebutton = TRUE)
## lattice
call.command <- "histogram"
call.final <- getHistCall(hist.graphics = svalue(.$savewd[["graphics"]]), hist.x=svalue(.$widgets[["x"]]),
hist.bin = svalue(.$widgets[["number of bins"]]),
hist.main=svalue(.$widgets[["main"]]),
hist.xlab=svalue(.$widgets[["xlab"]]),
hist.ylab=svalue(.$widgets[["ylab"]]),
hist.type= svalue(.$widgets[["type"]]),
hist.cond = svalue(.$savewd[["cond"]]),
hist.layout_x = svalue(.$savewd[["layout_x"]]),
hist.layout_y = svalue(.$savewd[["layout_y"]])
)
print(call.final)
setPKCode(list(pkcall=call.command, pklist=call.final))
setPKGGobi(list(x=svalue(.$widgets[["x"]])))
#dispose(.$window)
}
summary.uni.ggobiImageHandler = function(.,h,...)
{
currentPage <- svalue(pk.dialog.notebook)
if (currentPage == 0)
{
ErrorMessage("Please draw figure first!")
return(NULL)
}
g <- ggobiRun()
mydata <- getPKGGobi(currentPage)
display(g[1], pmode="Barchart", vars=list(X = mydata$x))
}
################################################################################
summary.bi.okButtonHandler = function(.,h,...)
{
#tmp.para <- NULL
pgraph = ggraphics(ps=6)
size(pgraph) <- c(getSubHeight()*0.5, getSubWidth()*0.5)
add(pk.dialog.notebook, pgraph, label = message,
#pageno = 3,
override.closebutton = TRUE)
call.command <- "xyplot"
call.final <- getScatterCall(hist.graphics = svalue(.$savewd[["graphics"]]),
hist.x=svalue(.$widgets[["x"]]),
hist.y=svalue(.$widgets[["y"]]),
#hist.bin = svalue(.$widgets[["number of bins"]]),
hist.main=svalue(.$widgets[["main"]]),
hist.xlab=svalue(.$widgets[["xlab"]]),
hist.ylab=svalue(.$widgets[["ylab"]]),
hist.type= svalue(.$widgets[["type"]]),
hist.cond = svalue(.$savewd[["cond"]]),
hist.layout_x = svalue(.$savewd[["layout_x"]]),
hist.layout_y = svalue(.$savewd[["layout_y"]])
)
print(call.final)
setPKCode(list(pkcall=call.command, pklist=call.final))
setPKGGobi(list(x=svalue(.$widgets[["x"]]), y=svalue(.$widgets[["y"]])))
#dispose(.$window)
}
summary.bi.ggobiImageHandler = function(.,h,...) # 0603
{
currentPage <- svalue(pk.dialog.notebook)
if (currentPage == 0)
{
ErrorMessage("Please draw figure first!")
return(NULL)
}
g <- ggobiRun()
mydata <- getPKGGobi(currentPage)
display(g[1], pmode="Scatterplot Display",
vars=list(X=mydata$x, Y=mydata$y))
}
## 3d does Not have ggplot2 implementation
summary.tri.okButtonHandler = function(.,h,...)
{
tmp.para <- NULL
pgraph = ggraphics(ps=6)
size(pgraph) <- c(getSubHeight()*0.5, getSubWidth()*0.5)
add(pk.dialog.notebook, pgraph, label = message,
#pageno = 3,
override.closebutton = FALSE)
###################################################
lattice.call <- "cloud"
x <- paste(svalue(.$widgets[["z"]]), "~", svalue(.$widgets[["x"]]), "*",
svalue(.$widgets[["y"]]), sep="")
lattice.list <- list(x=x, xlab=svalue(.$widgets[["xlab"]]),
ylab=svalue(.$widgets[["ylab"]]), zlab=svalue(.$widgets[["zlab"]]),
type= svalue(.$widgets[["type"]]),
main=svalue(.$widgets[["main"]]) , data= getCurrentData())
#if (svalue(.$widgets[["xlim"]])=="")
if (is.null(.$savewd[["conditional var"]]) ||(svalue(.$savewd[["conditional var"]])==""))
{
lattice.list$x <- as.formula(lattice.list$x)
print(do.call(lattice.call, lattice.list))
}
else
{
lattice.list$x <- as.formula(paste(lattice.list$x, "|", svalue(.$savewd[["conditional var"]]), sep=" "))
lattice.list$layout <- as.numeric(c(svalue(.$savewd[["layout_x"]]), svalue(.$savewd[["layout_y"]])))
print(do.call(lattice.call, lattice.list))
}
}
summary.tri.ggobiImageHandler = function(.,h,...)
{
x.name <- svalue(.$widgets[["x"]])
x.ind <- which(colnames(tmp.data)== x.name)
y.name <- svalue(.$widgets[["y"]])
y.ind <- which(colnames(tmp.data)== y.name)
old.ind <- c(1:length(colnames(tmp.data)))
old.ind <- old.ind[-c(x.ind, y.ind)]
tmp.data <- tmp.data[c(x.ind, y.ind, old.ind)]
g <- ggobi(tmp.data)
#display(g[1], pmode="Barchart", vars=list(X=svalue(.$widgets[[1]])))
#display(g[1], pmode="Scatterplot Display",
#vars=list(X=svalue(.$widgets[["x"]]), Y=svalue(.$widgets[["y"]])))
}
summary.para.okButtonHandler = function(.,h,...)
{
currentMain <- svalue(pmg.dialog.notebook)
## directly apply
need.var <- svalue(.$widgets[["x"]])
if (length(need.var) < 1)
{
ErrorMessage("Please choose x variables!")
return(invisible(NULL))
}
all.data <- getCurrentData(currentMain)
part.data <- getCurrentData(currentMain)[,need.var]
call.command <- "parallel"
if (is.null(.$savewd[["conditional var"]]) ||(svalue(.$savewd[["conditional var"]])==""))
{
x <- as.formula("~part.data")
call.final <- parallel(x=x, data=all.data,
main=svalue(.$widgets[["main"]]) ,
horizontal.axis= as.logical(svalue(.$widgets[["horizontal"]])))
}
else
{
cond <- svalue(.$savewd[["conditional var"]])
cond.logic <- colnames(Theoph) %in% cond
if (any(cond.logic))
{
cond.ind <- which(cond.logic)
part.data <- part.data[,-c(cond.ind)]
}
x <- as.formula(paste("~part.data", "|", cond, sep=""))
call.final <- parallel(x=x, data=all.data,
main=svalue(.$widgets[["main"]]) ,
horizontal.axis= as.logical(svalue(.$widgets[["horizontal"]])),
layout= as.numeric(c(svalue(.$savewd[["layout_x"]]), svalue(.$savewd[["layout_y"]]))))
}
pgraph = ggraphics(ps=6)
size(pgraph) <- c(getSubHeight()*0.5, getSubWidth()*0.5)
add(pk.dialog.notebook, pgraph, label = message,
override.closebutton = TRUE)
print(call.final)
setPKCode(list(pkcall=call.command, pklist=call.final))
setPKGGobi(list(x=need.var ))
#print(parallel(~ para.data | factor(cond) , all.data, horizontal.axis= as.logical(svalue(.$widgets[["horizontal"]]))))
}
summary.para.ggobiImageHandler = function(.,h,...)
{
currentPage <- svalue(pk.dialog.notebook)
if (currentPage == 0)
{
ErrorMessage("Please draw figure first!")
return(NULL)
}
g <- ggobiRun()
mydata <- getPKGGobi(currentPage)
display(g[1], "Parallel Coordinates Display", vars=list(X=mydata$x))
}
summary.heat.okButtonHandler = function(.,h,...)
{
#tmp.para <- NULL
#for(i in names(.$widgetList))
#{
## store vals in props of super
# .$.super$props[[i]] <- svalue(.$widgets[[i]]) # pre 0.4-0
#h$action$super$props[[i]] <- svalue(.$widgets[[i]])
#}
#size(.$widgets[["x"]]) <- c(200, 200)
need.var <- svalue(.$widgets[["x"]])
if (length(need.var) < 1)
{
ErrorMessage("Please choose x variables!")
return(invisible(NULL))
}
part.data <- getCurrentData()[,need.var]
#print(parallel(~ para.data | factor(cond) , all.data, horizontal.axis= as.logical(svalue(.$widgets[["horizontal"]]))))
pgraph = ggraphics(ps=6)
size(pgraph) <- c(getSubHeight()*0.5, getSubWidth()*0.5)
add(pk.dialog.notebook, pgraph, label = message,
#pageno = 3,
override.closebutton = TRUE)
call.command <- "heatmap"
#old.par <- par(no.readonly = TRUE)
t <- par()
par(t)
#on.exit(par(old.par))
x <- as.matrix(part.data)
if (svalue(.$widgets[["dendrogram for row"]]) == "no")
{
if (svalue(.$widgets[["dendrogram for column"]]) == "no")
{
print(call.final <- heatmap(x, Rowv=NA, Colv=NA, scale= svalue(.$widgets[["scale by"]]), main=svalue(.$widgets[["main"]])))
setPKCode(list(pkcall=call.command, pklist= call.final))
}
else
{
print(call.final <- heatmap(x, Rowv=NA, scale= svalue(.$widgets[["scale by"]]), main=svalue(.$widgets[["main"]])))
setPKCode(list(pkcall=call.command, pklist= call.final))
}
}
else
{
if (svalue(.$widgets[["dendrogram for column"]]) == "no")
{
print(call.final <- heatmap(x, Colv=NA, scale= svalue(.$widgets[["scale by"]]), main=svalue(.$widgets[["main"]])))
setPKCode(list(pkcall=call.command, pklist= call.final))
}
else
{
print(call.final <- heatmap(x, scale= svalue(.$widgets[["scale by"]]), main=svalue(.$widgets[["main"]])))
setPKCode(list(pkcall=call.command, pklist= call.final))
}
}
}
summary.heat.ggobiImageHandler = function(.,h,...)
{
x.name <- svalue(.$widgets[["x"]])
x.ind <- which(colnames(tmp.data)== x.name)
y.name <- svalue(.$widgets[["y"]])
y.ind <- which(colnames(tmp.data)== y.name)
old.ind <- c(1:length(colnames(tmp.data)))
old.ind <- old.ind[-c(x.ind, y.ind)]
tmp.data <- tmp.data[c(x.ind, y.ind, old.ind)]
g <- ggobi(tmp.data)
#display(g[1], pmode="Barchart", vars=list(X=svalue(.$widgets[[1]])))
#display(g[1], pmode="Scatterplot Display",
#vars=list(X=svalue(.$widgets[["x"]]), Y=svalue(.$widgets[["y"]])))
}
summary.matrix.okButtonHandler = function(.,h,...)
{
pgraph = ggraphics(ps=6)
size(pgraph) <- c(getSubHeight()*0.5, getSubWidth()*0.5)
add(pk.dialog.notebook, pgraph, label = message,
override.closebutton = TRUE)
chose.var <- svalue(.$widgets[["x"]])
if (length(chose.var) < 1)
{
ErrorMessage("Please choose x variables!")
return(invisible(NULL))
}
currentMain <- svalue(pmg.dialog.notebook)
tmp.data <- getCurrentData(currentMain)
part.data <- tmp.data[, chose.var]
call.final <- getPKMatrixplotCall(hist.graphics= svalue(.$savewd[["graphics"]]), part.data)
call.command <- "splom"
print(call.final)
setPKCode(list(pkcall=call.command, pklist=call.final))
setPKGGobi(list(x=chose.var ))
currentPage <- svalue(pk.dialog.notebook)
setDataSpecialPlot(part.data, as.character(currentPage))
}
summary.matrix.ggobiImageHandler = function(.,h,...)
{
currentPage <- svalue(pk.dialog.notebook)
if (currentPage == 0)
{
ErrorMessage("Please draw figure first!")
return(NULL)
}
g <- ggobiRun()
mydata <- getPKGGobi(currentPage)
display(g[1], "Scatterplot Matrix", vars=list(X=mydata$x))
}
################################################################################
################################################################################
model.ind.okButtonHandler = function(.,h,...)
{
# ind plot
match.term <- getTerm()
hist.cond <- match.term[match.term$TermName == "ID",]$VarName
if (svalue(.$widgets[["main"]])=="")
newstr <- paste(svalue(.$widgets[["y"]]), "vs", svalue(.$widgets[["x"]]), sep="")
else newstr <- svalue(.$widgets[["main"]])
pgraph = ggraphics(ps=6)
add(pk.dialog.notebook, pgraph, label = newstr,
override.closebutton = TRUE)
if (svalue(.$widgets[["x"]]) == "")
{
ErrorMessage("You have to choose one x value!")
return(invisible(NULL))
}
if (svalue(.$widgets[["y"]]) != "")
{
call.command <- "xyplot"
call.final <- getScatterCall(hist.graphics = svalue(.$savewd[["graphics"]]),
hist.x=svalue(.$widgets[["x"]]),
hist.y=svalue(.$widgets[["y"]]),
hist.main=svalue(.$widgets[["main"]]),
hist.xlab=svalue(.$widgets[["xlab"]]),
hist.ylab=svalue(.$widgets[["ylab"]]),
hist.type= svalue(.$widgets[["type"]]),
hist.cond = hist.cond,
hist.layout_x = svalue(.$savewd[["layout_x"]]),
hist.layout_y = svalue(.$savewd[["layout_y"]])
)
}
else
{
call.command <- "histogram"
call.final <- getHistCall(hist.graphics = svalue(.$savewd[["graphics"]]),
hist.x=svalue(.$widgets[["x"]]),
hist.bin = "",
hist.main=svalue(.$widgets[["main"]]),
hist.xlab=svalue(.$widgets[["xlab"]]),
hist.ylab=svalue(.$widgets[["ylab"]]),
hist.type= svalue(.$widgets[["type"]]),
hist.cond = hist.cond,
hist.layout_x = svalue(.$savewd[["layout_x"]]),
hist.layout_y = svalue(.$savewd[["layout_y"]])
)
}
print(call.final)
setPKCode(list(pkcall=call.command, pklist=call.final))
setPKGGobi(list(x=svalue(.$widgets[["x"]]), y=svalue(.$widgets[["y"]]) ))
}
###############################################################################
model.gof.okButtonHandler = function(.,h,...)
{
match.term <- getTerm()
mywres <- match.term[match.term$TermName == "WRES",]$VarName
mypred <- match.term[match.term$TermName == "PRED",]$VarName
myipre <- match.term[match.term$TermName == "IPRE",]$VarName
mydv <- match.term[match.term$TermName == "DV",]$VarName
myidv <- match.term[match.term$TermName == "IDV",]$VarName
pkdata <- getCurrentData()
mypackage <- svalue(.$savewd[["graphics"]])
# DV vs PRED
mylist <- list()
myx <- svalue(.$widgets[["PRED_1"]])
myy <- svalue(.$widgets[["DV_1"]])
newstr <- paste(myy, "vs", myx, sep=" ")
plotType <- "scatter"
pgraph = ggraphics(ps=6)
add(pk.dialog.notebook, pgraph, label = newstr,
#pageno = 3,
override.closebutton = TRUE)
call.command <- "xyplot"
call.final <- getPKScatterCall(hist.graphics = svalue(.$savewd[["graphics"]]),
hist.x=myx,
hist.y=myy,
hist.main="",
hist.xlab=myx,
hist.ylab=myy,
hist.type= "",
hist.cond = "",
hist.layout_x = svalue(.$savewd[["layout_x"]]),
hist.layout_y = svalue(.$savewd[["layout_y"]]),
hist.data = pkdata
)
#print(do.call(mycall, mylist))
print(call.final)
setPKCode(list(pkcall=call.command, pklist=call.final))
setPKGGobi(list(x=myx, y=myy ))
# DV vs IPRED:
mylist <- list()
myx <- svalue(.$widgets[["IPRE"]])
myy <- svalue(.$widgets[["DV_2"]])
newstr <- paste(myy, "vs", myx, sep=" ")
plotType <- "scatter"
pgraph = ggraphics(ps=6)
add(pk.dialog.notebook, pgraph, label = newstr,
#pageno = 3,
override.closebutton = TRUE)
call.command <- "xyplot"
call.final <- getPKScatterCall(hist.graphics = svalue(.$savewd[["graphics"]]),
hist.x=myx,
hist.y=myy,
hist.main="",
hist.xlab=myx,
hist.ylab=myy,
hist.type= "",
hist.cond = "",
hist.layout_x = svalue(.$savewd[["layout_x"]]),
hist.layout_y = svalue(.$savewd[["layout_y"]]),
hist.data = pkdata
)
print(call.final)
setPKCode(list(pkcall=call.command, pklist=call.final))
setPKGGobi(list(x=myx, y=myy ))
# WRES vs IDV
mylist <- list()
myx <- svalue(.$widgets[["IDV_3"]])
myy <- svalue(.$widgets[["WRES_3"]])
newstr <- paste(myy, "vs", myx, sep=" ")
plotType <- "scatter"
pgraph = ggraphics(ps=6)
add(pk.dialog.notebook, pgraph, label = newstr,
#pageno = 3,
override.closebutton = TRUE)
call.command <- "xyplot"
call.final <- getPKScatterCall(hist.graphics = svalue(.$savewd[["graphics"]]),
hist.x=myx,
hist.y=myy,
hist.main="",
hist.xlab=myx,
hist.ylab=myy,
hist.type= "",
hist.cond = "",
hist.layout_x = svalue(.$savewd[["layout_x"]]),
hist.layout_y = svalue(.$savewd[["layout_y"]]),
hist.data = pkdata
)
print(call.final)
setPKCode(list(pkcall=call.command, pklist=call.final))
setPKGGobi(list(x=myx, y=myy ))
# PRED vs IDV:
mylist <- list()
myx <- svalue(.$widgets[["IDV_4"]])
myy <- svalue(.$widgets[["PRED_4"]])
newstr <- paste(myy, "vs", myx, sep=" ")
plotType <- "scatter"
pgraph = ggraphics(ps=6)
add(pk.dialog.notebook, pgraph, label = newstr,
#pageno = 3,
override.closebutton = TRUE)
call.command <- "xyplot"
call.final <- getPKScatterCall(hist.graphics = svalue(.$savewd[["graphics"]]),
hist.x=myx,
hist.y=myy,
hist.main="",
hist.xlab=myx,
hist.ylab=myy,
hist.type= "",
hist.cond = "",
hist.layout_x = svalue(.$savewd[["layout_x"]]),
hist.layout_y = svalue(.$savewd[["layout_y"]]),
hist.data = pkdata
)
print(call.final)
setPKCode(list(pkcall=call.command, pklist=call.final))
setPKGGobi(list(x=myx, y=myy ))
# IPRED vs IDV
mylist <- list()
myx <- svalue(.$widgets[["IDV_5"]])
myy <- svalue(.$widgets[["IPRE_5"]])
newstr <- paste(myy, "vs", myx, sep=" ")
plotType <- "scatter"
pgraph = ggraphics(ps=6)
add(pk.dialog.notebook, pgraph, label = newstr,
#pageno = 3,
override.closebutton = TRUE)
call.command <- "xyplot"
call.final <- getPKScatterCall(hist.graphics = svalue(.$savewd[["graphics"]]),
hist.x=myx,
hist.y=myy,
hist.main="",
hist.xlab=myx,
hist.ylab=myy,
hist.type= "",
hist.cond = "",
hist.layout_x = svalue(.$savewd[["layout_x"]]),
hist.layout_y = svalue(.$savewd[["layout_y"]]),
hist.data = pkdata
)
print(call.final)
setPKCode(list(pkcall=call.command, pklist=call.final))
setPKGGobi(list(x=myx, y=myy ))
}
model.struct.okButtonHandler = function(.,h,...)
{
match.term <- getTerm()
mywres <- match.term[match.term$TermName == "WRES",]$VarName
mypred <- match.term[match.term$TermName == "PRED",]$VarName
mycov <- match.term[match.term$TermName == "COV",]$VarName
myipre <- match.term[match.term$TermName == "IPRE",]$VarName
pkdata <- getCurrentData()
mypackage <- svalue(.$savewd[["graphics"]])
# PRED vs DV|IDV
mylist <- list()
myx <- svalue(.$widgets[["DV_1"]])
myy <- svalue(.$widgets[["PRED_1"]])
cond <- svalue(.$widgets[["IDV_1"]])
part.data <- pkdata[c(myx,myy,cond)]
newstr <- paste(myy, "vs", myx, "|", cond, sep=" ")
plotType <- "scatter"
pgraph = ggraphics(ps=6)
add(pk.dialog.notebook, pgraph, label = newstr,
override.closebutton = TRUE)
call.command <- "xyplot"
call.final <- getPKScatterCall(hist.graphics = svalue(.$savewd[["graphics"]]),
hist.x=myx,
hist.y=myy,
hist.main=newstr,
hist.xlab=myx,
hist.ylab=myy,
hist.type= "",
hist.cond = cond,
hist.layout_x = svalue(.$savewd[["layout_x"]]),
hist.layout_y = svalue(.$savewd[["layout_y"]]),
hist.data = part.data
)
print(call.final)
setPKCode(list(pkcall=call.command, pklist=call.final))
setPKGGobi(list(x=myx, y=myy ))
# IPRED vs DV|IDV:
mylist <- list()
myx <- svalue(.$widgets[["DV_2"]])
myy <- svalue(.$widgets[["IPRE"]])
cond <- svalue(.$widgets[["IDV_2"]])
part.data <- pkdata[c(myx,myy,cond)]
newstr <- paste(myy, "vs", myx, "|", cond, sep=" ")
plotType <- "scatter"
pgraph = ggraphics(ps=6)
add(pk.dialog.notebook, pgraph, label = newstr,
#pageno = 3,
override.closebutton = TRUE)
call.command <- "xyplot"
call.final <- getPKScatterCall(hist.graphics = svalue(.$savewd[["graphics"]]),
hist.x=myx,
hist.y=myy,
hist.main=newstr,
hist.xlab=myx,
hist.ylab=myy,
hist.type= "",
hist.cond = cond,
hist.layout_x = svalue(.$savewd[["layout_x"]]),
hist.layout_y = svalue(.$savewd[["layout_y"]]),
hist.data = part.data
)
print(call.final)
setPKCode(list(pkcall=call.command, pklist=call.final))
setPKGGobi(list(x=myx, y=myy ))
# WRES vs IDV:
mylist <- list()
myx <- svalue(.$widgets[["IDV_3"]])
myy <- svalue(.$widgets[["WRES_3"]])
newstr <- paste(myy, "vs", myx, sep=" ")
plotType <- "scatter"
pgraph = ggraphics(ps=6)
add(pk.dialog.notebook, pgraph, label = newstr,
#pageno = 3,
override.closebutton = TRUE)
call.command <- "xyplot"
call.final <- getPKScatterCall(hist.graphics = svalue(.$savewd[["graphics"]]),
hist.x=myx,
hist.y=myy,
hist.main="",
hist.xlab=myx,
hist.ylab=myy,
hist.type= "",
hist.cond = "",
hist.layout_x = svalue(.$savewd[["layout_x"]]),
hist.layout_y = svalue(.$savewd[["layout_y"]]),
hist.data = pkdata
)
print(call.final)
setPKCode(list(pkcall=call.command, pklist=call.final))
setPKGGobi(list(x=myx, y=myy ))
# WRES vs IDV (bw):
mylist <- list()
myx <- svalue(.$widgets[["IDV_4"]])
myy <- svalue(.$widgets[["WRES_4"]])
newstr <- paste(myy, "vs", myx, sep=" ")
plotType <- "bwplot"
pgraph = ggraphics(ps=6)
add(pk.dialog.notebook, pgraph, label = newstr,
override.closebutton = TRUE)
pkdata[[myx]] <- factor(pkdata[[myx]])
call.command <- "bwplot"
call.final <- getPKBwplotCall(hist.graphics = svalue(.$savewd[["graphics"]]),
hist.x=myx,
hist.y=myy,
hist.main="",
hist.xlab=myx,
hist.ylab=myy,
hist.type= "",
hist.cond = "",
hist.layout_x = svalue(.$savewd[["layout_x"]]),
hist.layout_y = svalue(.$savewd[["layout_y"]]),
hist.data = pkdata
)
print(call.final)
setPKCode(list(pkcall=call.command, pklist=call.final))
setPKGGobi(list(x=myx, y=myy ))
# WRES vs PRED:
mylist <- list()
myx <- svalue(.$widgets[["PRED_5"]])
myy <- svalue(.$widgets[["WRES_5"]])
newstr <- paste(myy, "vs", myx, sep=" ")
plotType <- "scatter"
pgraph = ggraphics(ps=6)
add(pk.dialog.notebook, pgraph, label = newstr,
#pageno = 3,
override.closebutton = TRUE)
call.command <- "xyplot"
call.final <- getPKScatterCall(hist.graphics = svalue(.$savewd[["graphics"]]),
hist.x=myx,
hist.y=myy,
hist.main="",
hist.xlab=myx,
hist.ylab=myy,
hist.type= "",
hist.cond = "",
hist.layout_x = svalue(.$savewd[["layout_x"]]),
hist.layout_y = svalue(.$savewd[["layout_y"]]),
hist.data = pkdata
)
print(call.final)
setPKCode(list(pkcall=call.command, pklist=call.final))
setPKGGobi(list(x=myx, y=myy ))
# TODO: figure does NOT make sense
# WRES vs PRED (bw):
mylist <- list()
myx <- svalue(.$widgets[["PRED_6"]])
myy <- svalue(.$widgets[["WRES_6"]])
newstr <- paste(myy, "vs", myx, sep=" ")
plotType <- "bwplot"
pgraph = ggraphics(ps=6)
add(pk.dialog.notebook, pgraph, label = newstr,
#pageno = 3,
override.closebutton = TRUE)
pkdata[[myx]] <- factor(pkdata[[myx]])
call.command <- "bwplot"
call.final <- getPKBwplotCall(hist.graphics = svalue(.$savewd[["graphics"]]),
hist.x=myx,
hist.y=myy,
hist.main="",
hist.xlab=myx,
hist.ylab=myy,
hist.type= "",
hist.cond = "",
hist.layout_x = svalue(.$savewd[["layout_x"]]),
hist.layout_y = svalue(.$savewd[["layout_y"]]),
hist.data = pkdata
)
print(call.final)
setPKCode(list(pkcall=call.command, pklist=call.final))
setPKGGobi(list(x=myx, y=myy ))
# PRED vs DV|Covariates
mylist <- list()
myx <- svalue(.$widgets[["DV_7"]])
myy <- svalue(.$widgets[["PRED_7"]])
cond <- svalue(.$widgets[["COV_7"]])
newstr <- paste(myy, "vs", myx, "|", cond, sep=" ")
plotType <- "scatter"
pgraph = ggraphics(ps=6)
add(pk.dialog.notebook, pgraph, label = newstr,
override.closebutton = TRUE)
call.command <- "xyplot"
call.final <- getPKScatterCall(hist.graphics = svalue(.$savewd[["graphics"]]),
hist.x=myx,
hist.y=myy,
hist.main=newstr,
hist.xlab=myx,
hist.ylab=myy,
hist.type= "",
hist.cond = cond,
hist.layout_x = svalue(.$savewd[["layout_x"]]),
hist.layout_y = svalue(.$savewd[["layout_y"]]),
hist.data = pkdata
)
print(call.final)
setPKCode(list(pkcall=call.command, pklist=call.final))
setPKGGobi(list(x=myx, y=myy ))
# IPRED vs DV|Covariates
mylist <- list()
myx <- svalue(.$widgets[["DV_8"]])
myy <- svalue(.$widgets[["IPRE_8"]])
cond <- svalue(.$widgets[["COV_8"]])
newstr <- paste(myy, "vs", myx, "|", cond, sep=" ")
plotType <- "scatter"
pgraph = ggraphics(ps=6)
add(pk.dialog.notebook, pgraph, label = newstr,
#pageno = 3,
override.closebutton = TRUE)
call.command <- "xyplot"
call.final <- getPKScatterCall(hist.graphics = svalue(.$savewd[["graphics"]]),
hist.x=myx,
hist.y=myy,
hist.main="",
hist.xlab=myx,
hist.ylab=myy,
hist.type= "",
hist.cond = cond,
hist.layout_x = svalue(.$savewd[["layout_x"]]),
hist.layout_y = svalue(.$savewd[["layout_y"]]),
hist.data = pkdata
)
print(call.final)
setPKCode(list(pkcall=call.command, pklist=call.final))
setPKGGobi(list(x=myx, y=myy ))
}
model.resid.okButtonHandler = function(.,h,...)
{
match.term <- getTerm()
mywres <- match.term[match.term$TermName == "WRES",]$VarName
mypred <- match.term[match.term$TermName == "PRED",]$VarName
mycov <- match.term[match.term$TermName == "COV",]$VarName
myipre <- match.term[match.term$TermName == "IPRE",]$VarName
pkdata <- getCurrentData()
mypackage <- svalue(.$savewd[["graphics"]])
# Distribution of WRES:
mylist <- list()
myx <- svalue(.$widgets[["Distribution of WRES:"]])
newstr <- paste("Distribution of", myx, sep=" ")
plotType <- "hist"
pgraph = ggraphics(ps=6)
add(pk.dialog.notebook, pgraph, label = newstr,
#pageno = 3,
override.closebutton = TRUE)
call.command <- "histogram"
call.final <- getPKHistCall(hist.graphics = svalue(.$savewd[["graphics"]]),
hist.x=myx,
hist.bin = "",
hist.main=newstr,
hist.xlab="",
hist.ylab="",
hist.type= "",
hist.cond ="",
hist.layout_x = svalue(.$savewd[["layout_x"]]),
hist.layout_y = svalue(.$savewd[["layout_y"]]),
hist.data = pkdata
)
print(call.final)
setPKCode(list(pkcall=call.command, pklist=call.final))
setPKGGobi(list(x=myx, y=NULL))
# Distribution of WRES (QQ):
mylist <- list()
myx <- svalue(.$widgets[["Distribution of WRES(QQ):"]])
newstr <- paste("Distribution of", myx, "(QQ)", sep=" ")
#plotType <- "hist"
pgraph = ggraphics(ps=6)
add(pk.dialog.notebook, pgraph, label = newstr,
#pageno = 3,
override.closebutton = TRUE)
call.command <- "qqmath"
call.final <- getPKQqmathCall(hist.graphics = svalue(.$savewd[["graphics"]]),
hist.x=myx,
hist.main=newstr,
hist.xlab="",
hist.ylab="",
hist.type= "",
hist.cond ="",
hist.layout_x = svalue(.$savewd[["layout_x"]]),
hist.layout_y = svalue(.$savewd[["layout_y"]]),
hist.data = pkdata
)
print(call.final)
setPKCode(list(pkcall=call.command, pklist=call.final))
setPKGGobi(list(x=myx, y=NULL ))
## TODO: only work for lattice
# Individual distribution of WRES:
mylist <- list()
myx <- svalue(.$widgets[[" of WRES:"]])
newstr <- paste("Individual distribution of", myx, sep=" ")
plotType <- "hist"
pgraph = ggraphics(ps=6)
add(pk.dialog.notebook, pgraph, label = newstr,
#pageno = 3,
override.closebutton = TRUE)
cond <- match.term[match.term$TermName == "ID",]$VarName
pkdata[[cond]] <- factor(pkdata[[cond]])
call.command <- "histogram"
call.final <- getPKHistCall(hist.graphics = svalue(.$savewd[["graphics"]]),
hist.x=myx,
hist.bin = "",
hist.main=newstr,
hist.xlab="",
hist.ylab="",
hist.type= "",
hist.cond =cond,
hist.layout_x = svalue(.$savewd[["layout_x"]]),
hist.layout_y = svalue(.$savewd[["layout_y"]]),
hist.data = pkdata
)
print(call.final)
setPKCode(list(pkcall=call.command, pklist=call.final))
currentPage <- svalue(pk.dialog.notebook)
setDataLayoutPlot(as.character(currentPage))
setPKGGobi(list(x=myx, y=NULL))
# Individual distribution of WRES (QQ):
mylist <- list()
myx <- svalue(.$widgets[[" of WRES(QQ)"]])
newstr <- paste("Distribution of", myx, "(QQ)", sep=" ")
#plotType <- "hist"
pgraph = ggraphics(ps=6)
add(pk.dialog.notebook, pgraph, label = newstr,
#pageno = 3,
override.closebutton = TRUE)
## TODO: make ggplot for qq works too
call.command <- "qqmath"
call.final <- getPKQqmathCall(hist.graphics = svalue(.$savewd[["graphics"]]),
hist.x=myx,
hist.main=newstr,
hist.xlab="",
hist.ylab="",
hist.type= "",
hist.cond ="",
hist.layout_x = svalue(.$savewd[["layout_x"]]),
hist.layout_y = svalue(.$savewd[["layout_y"]]),
hist.data = pkdata
)
print(call.final)
setPKCode(list(pkcall=call.command, pklist=call.final))
currentPage <- svalue(pk.dialog.notebook)
setDataLayoutPlot(as.character(currentPage))
setPKGGobi(list(x=myx, y=NULL ))
## |WRES| vs PRED
mylist <- list()
myx <- svalue(.$widgets[["PRED_1"]])
myy <- svalue(.$widgets[["|WRES|_1"]])
## get |WRES|
part.data <- pkdata[c(myx,myy)]
part.data[,2] <- abs(part.data[,2])
newstr <- paste(myy, "vs", myx, sep=" ")
plotType <- "scatter"
pgraph = ggraphics(ps=6)
add(pk.dialog.notebook, pgraph, label = newstr,
#pageno = 3,
override.closebutton = TRUE)
call.command <- "xyplot"
call.final <- getPKScatterCall(hist.graphics = svalue(.$savewd[["graphics"]]),
hist.x=myx,
hist.y=myy,
hist.main="",
hist.xlab=myx,
hist.ylab="|WRES|",
hist.type= "",
hist.cond = "",
hist.layout_x = svalue(.$savewd[["layout_x"]]),
hist.layout_y = svalue(.$savewd[["layout_y"]]),
hist.data = part.data
)
print(call.final)
setPKCode(list(pkcall=call.command, pklist=call.final))
currentPage <- svalue(pk.dialog.notebook)
setDataSpecialPlot(part.data, as.character(currentPage))
setPKGGobi(list(x=myx, y=myy ))
# Covariates vs |WRES| (bw):
mylist <- list()
myx <- svalue(.$widgets[["Covariates_2"]])
myy <- svalue(.$widgets[["|WRES|_2"]])
# get |WRES|
part.data <- pkdata[c(myx,myy)]
part.data[,1] <- abs(part.data[,1])
#myx <- paste("|",myx,"|", sep="")
colnames(part.data) <- c(myx, myy)
newstr <- paste(myy, "vs", myx, sep=" ")
plotType <- "bwplot"
pgraph = ggraphics(ps=6)
add(pk.dialog.notebook, pgraph, label = newstr,
#pageno = 3,
override.closebutton = TRUE)
part.data[[myx]] <- factor(part.data[[myx]])
call.command <- "bwplot"
call.final <- getPKBwplotCall(hist.graphics = svalue(.$savewd[["graphics"]]),
hist.x=myx,
hist.y=myy,
hist.main="",
hist.xlab=myx,
hist.ylab="|WRES|",
hist.type= "",
hist.cond = "",
hist.layout_x = svalue(.$savewd[["layout_x"]]),
hist.layout_y = svalue(.$savewd[["layout_y"]]),
hist.data = part.data
)
print(call.final)
setPKCode(list(pkcall=call.command, pklist=call.final))
currentPage <- svalue(pk.dialog.notebook)
setDataSpecialPlot(part.data, as.character(currentPage))
setPKGGobi(list(x=myx, y=myy ))
# |WRES| vs PRED|Covariates
mylist <- list()
myx <- svalue(.$widgets[["PRED_3"]])
myy <- svalue(.$widgets[["|WRES|_3"]])
cond <- svalue(.$widgets[["Covariates_3"]])
part.data <- pkdata[c(myx, myy, cond)]
part.data[,2] <- abs(part.data[,2])
newstr <- paste("|", myy, "|", "vs", myx, "|", cond, sep=" ")
plotType <- "scatter"
pgraph = ggraphics(ps=6)
add(pk.dialog.notebook, pgraph, label = newstr,
override.closebutton = TRUE)
call.command <- "xyplot"
call.final <- getPKScatterCall(hist.graphics = svalue(.$savewd[["graphics"]]),
hist.x=myx,
hist.y=myy,
hist.main=newstr,
hist.xlab=myx,
hist.ylab="|WRES|",
hist.type= "",
hist.cond = cond,
hist.layout_x = svalue(.$savewd[["layout_x"]]),
hist.layout_y = svalue(.$savewd[["layout_y"]]),
hist.data = part.data
)
print(call.final)
setPKCode(list(pkcall=call.command, pklist=call.final))
currentPage <- svalue(pk.dialog.notebook)
setDataSpecialPlot(part.data, as.character(currentPage))
setDataLayoutPlot(as.character(currentPage))
setPKGGobi(list(x=myx, y=myy ))
#TODO:
# |IWRES| vs IPRED|Covariates
# Autocorrelation of WRES: Plot of WRESi against WRESi+1
mylist <- list()
mywres <- svalue(.$widgets[["Autocorrelation of WRES:"]])
tmp <- pkdata[[mywres]]
mydf <- data.frame(WRESi=tmp[-length(tmp)], WRESi_1=tmp[-1])
myx <- "WRESi"
myy <- "WRESi_1"
newstr <- paste(myy, "vs", myx, sep=" ")
plotType <- "scatter"
pgraph = ggraphics(ps=6)
add(pk.dialog.notebook, pgraph, label = newstr,
#pageno = 3,
override.closebutton = TRUE)
call.command <- "xyplot"
call.final <- getPKScatterCall(hist.graphics = svalue(.$savewd[["graphics"]]),
hist.x=myx,
hist.y=myy,
hist.main="",
hist.xlab=myx,
hist.ylab=myy,
hist.type= "",
hist.cond ="",
hist.layout_x = svalue(.$savewd[["layout_x"]]),
hist.layout_y = svalue(.$savewd[["layout_y"]]),
hist.data = mydf
)
print(call.final)
setPKCode(list(pkcall=call.command, pklist=call.final))
currentPage <- svalue(pk.dialog.notebook)
setDataSpecialPlot(mydf, as.character(currentPage))
setPKGGobi(list(x=myx, y=myy ))
}
model.para.okButtonHandler = function(.,h,...)
{
match.term <- getTerm()
mypara <- match.term[match.term$TermName == "PARAMETERS",]$VarName
pkdata <- getCurrentData()
mypackage <- svalue(.$savewd[["graphics"]])
# Distribution of parameters:
mylist <- list()
myx <- svalue(.$widgets[["Distribution of parameters:"]])
newstr <- paste("Distribution of", myx, sep=" ")
plotType <- "hist"
pgraph = ggraphics(ps=6)
add(pk.dialog.notebook, pgraph, label = newstr,
override.closebutton = TRUE)
call.command <- "histogram"
call.final <- getPKHistCall(hist.graphics = svalue(.$savewd[["graphics"]]),
hist.x=myx,
hist.bin = "",
hist.main=newstr,
hist.xlab="",
hist.ylab="",
hist.type= "",
hist.cond ="",
hist.layout_x = svalue(.$savewd[["layout_x"]]),
hist.layout_y = svalue(.$savewd[["layout_y"]]),
hist.data = pkdata
)
print(call.final)
setPKCode(list(pkcall=call.command, pklist=call.final))
setPKGGobi(list(x=myx, y=NULL))
# Distribution of parameters (QQ):
mylist <- list()
myx <- svalue(.$widgets[["Distribution of parameters (QQ):"]])
newstr <- paste("Distribution of", myx, "(QQ)", sep=" ")
#plotType <- "hist"
pgraph = ggraphics(ps=6)
add(pk.dialog.notebook, pgraph, label = newstr,
#pageno = 3,
override.closebutton = TRUE)
## TODO: make ggplot for qq works too
call.command <- "qqmath"
call.final <- getPKQqmathCall(hist.graphics = svalue(.$savewd[["graphics"]]),
hist.x=myx,
hist.main=newstr,
hist.xlab="",
hist.ylab="",
hist.type= "",
hist.cond ="",
hist.layout_x = svalue(.$savewd[["layout_x"]]),
hist.layout_y = svalue(.$savewd[["layout_y"]]),
hist.data = pkdata
)
print(call.final)
setPKCode(list(pkcall=call.command, pklist=call.final))
setPKGGobi(list(x=myx, y=NULL))
# Scatterplot matrix of parameters
newstr <- "Scatterplot matrix of parameters"
plotType <- "smatrix"
pgraph = ggraphics(ps=6)
add(pk.dialog.notebook, pgraph, label = newstr,
#pageno = 3,
override.closebutton = TRUE)
tmp.data <- pkdata[c(mypara)]
## TODO
if (ncol(tmp.data) > 1)
{
call.command <- "matrix"
call.final <- getPKMatrixplotCall(hist.graphics= svalue(.$savewd[["graphics"]]), tmp.data)
print(call.final)
setPKCode(list(pkcall=call.command, pklist=call.final))
setPKGGobi(list(x=colnames(tmp.data), y=NULL))
}
# Parameter vs parameter:
mylist <- list()
myx <- svalue(.$widgets[["Parameters_x:"]])
myy <- svalue(.$widgets[["Parameters_y:"]])
newstr <- paste(myy, "vs", myx, sep=" ")
plotType <- "scatter"
pgraph = ggraphics(ps=6)
add(pk.dialog.notebook, pgraph, label = newstr,
#pageno = 3,
override.closebutton = TRUE)
call.command <- "xyplot"
call.final <- getPKScatterCall(hist.graphics = svalue(.$savewd[["graphics"]]),
hist.x=myx,
hist.y=myy,
hist.main="",
hist.xlab=myx,
hist.ylab=myy,
hist.type= "",
hist.cond = "",
hist.layout_x = svalue(.$savewd[["layout_x"]]),
hist.layout_y = svalue(.$savewd[["layout_y"]]),
hist.data = pkdata
)
print(call.final)
setPKCode(list(pkcall=call.command, pklist=call.final))
setPKGGobi(list(x=myx, y=myy ))
}
model.cov.okButtonHandler = function(.,h,...)
{
mylist <- list()
match.term <- getTerm()
myeta <- match.term[match.term$TermName == "ETA",]$VarName
mycov <- match.term[match.term$TermName == "COV",]$VarName
mypara <- match.term[match.term$TermName == "PARAMETERS",]$VarName
pkdata <- getCurrentData()
mypackage <- svalue(.$savewd[["graphics"]])
# Scatterplot matrix of covariates
newstr <- "Scatterplot matrix of covariates"
plotType <- "smatrix"
pgraph = ggraphics(ps=6)
add(pk.dialog.notebook, pgraph, label = newstr,
#pageno = 3,
override.closebutton = TRUE)
tmp.data <- pkdata[c(mycov)]
## TODO
if (ncol(tmp.data) > 1)
{
call.command <- "matrix"
call.final <- getPKMatrixplotCall(hist.graphics= svalue(.$savewd[["graphics"]]), tmp.data)
print(call.final)
setPKCode(list(pkcall=call.command, pklist=call.final))
setPKGGobi(list(x=colnames(tmp.data), y=NULL))
}
#Parameters vs covariates:
mylist <- list()
myx <- svalue(.$widgets[["Cov_P:"]])
myy <- svalue(.$widgets[["Parameters:"]])
newstr <- paste(myy, "vs", myx, sep=" ")
plotType <- "scatter"
pgraph = ggraphics(ps=6)
add(pk.dialog.notebook, pgraph, label = newstr,
#pageno = 3,
override.closebutton = TRUE)
call.command <- "xyplot"
call.final <- getPKScatterCall(hist.graphics = svalue(.$savewd[["graphics"]]),
hist.x=myx,
hist.y=myy,
hist.main="",
hist.xlab=myx,
hist.ylab=myy,
hist.type= "",
hist.cond = "",
hist.layout_x = svalue(.$savewd[["layout_x"]]),
hist.layout_y = svalue(.$savewd[["layout_y"]]),
hist.data = pkdata
)
print(call.final)
setPKCode(list(pkcall=call.command, pklist=call.final))
setPKGGobi(list(x=myx, y=myy ))
#ETAs vs covariates::
mylist <- list()
myx <- svalue(.$widgets[["Cov_E:"]])
myy <- svalue(.$widgets[["ETAS:"]])
newstr <- paste(myy, "vs", myx, sep=" ")
plotType <- "scatter"
pgraph = ggraphics(ps=6)
add(pk.dialog.notebook, pgraph, label = newstr,
#pageno = 3,
override.closebutton = TRUE)
call.command <- "xyplot"
call.final <- getPKScatterCall(hist.graphics = svalue(.$savewd[["graphics"]]),
hist.x=myx,
hist.y=myy,
hist.main="",
hist.xlab=myx,
hist.ylab=myy,
hist.type= "",
hist.cond = "",
hist.layout_x = svalue(.$savewd[["layout_x"]]),
hist.layout_y = svalue(.$savewd[["layout_y"]]),
hist.data = pkdata
)
print(call.final)
setPKCode(list(pkcall=call.command, pklist=call.final))
setPKGGobi(list(x=myx, y=myy ))
#WRES vs covariates:
mylist <- list()
myx <- svalue(.$widgets[["Cov_W:"]])
myy <- svalue(.$widgets[["WRES:"]])
newstr <- paste(myy, "vs", myx, sep=" ")
plotType <- "scatter"
pgraph = ggraphics(ps=6)
add(pk.dialog.notebook, pgraph, label = newstr,
#pageno = 3,
override.closebutton = TRUE)
call.command <- "xyplot"
call.final <- getPKScatterCall(hist.graphics = svalue(.$savewd[["graphics"]]),
hist.x=myx,
hist.y=myy,
hist.main="",
hist.xlab=myx,
hist.ylab=myy,
hist.type= "",
hist.cond = "",
hist.layout_x = svalue(.$savewd[["layout_x"]]),
hist.layout_y = svalue(.$savewd[["layout_y"]]),
hist.data = pkdata
)
print(call.final)
setPKCode(list(pkcall=call.command, pklist=call.final))
setPKGGobi(list(x=myx, y=myy ))
}
###############################################################################
model.random.okButtonHandler = function(.,h,...)
{
pkdata <- getCurrentData()
mylist <- list()
match.term <- getTerm()
myterm <- match.term[match.term$TermName == "ETA",]$VarName
mypackage <- svalue(.$savewd[["graphics"]])
#Distribution of ETAS:
newstr <- "Distribution of ETAS"
plotType <- "hist"
pgraph = ggraphics(ps=6)
add(pk.dialog.notebook, pgraph, label = newstr,
#pageno = 3,
override.closebutton = TRUE)
myx <- svalue(.$widgets[["Distribution of ETAS"]])
call.command <- "histogram"
call.final <- getPKHistCall(hist.graphics = svalue(.$savewd[["graphics"]]),
hist.x=myx,
hist.bin = "",
hist.main=newstr,
hist.xlab="",
hist.ylab="",
hist.type= "",
hist.cond ="",
hist.layout_x = svalue(.$savewd[["layout_x"]]),
hist.layout_y = svalue(.$savewd[["layout_y"]]),
hist.data = pkdata
)
print(call.final)
setPKCode(list(pkcall=call.command, pklist=call.final))
setPKGGobi(list(x=myx, y=NULL))
#Distribution of ETAs (QQ):
newstr <- "Distribution of ETAS(QQ)"
#plotType <- "hist"
pgraph = ggraphics(ps=6)
add(pk.dialog.notebook, pgraph, label = newstr,
override.closebutton = TRUE)
mylist <- list()
myx <- svalue(.$widgets[["Distribution of ETAs (QQ)"]])
call.command <- "qqmath"
call.final <- getPKQqmathCall(hist.graphics = svalue(.$savewd[["graphics"]]),
hist.x=myx,
hist.main=newstr,
hist.xlab="",
hist.ylab="",
hist.type= "",
hist.cond ="",
hist.layout_x = svalue(.$savewd[["layout_x"]]),
hist.layout_y = svalue(.$savewd[["layout_y"]]),
hist.data = pkdata
)
print(call.final)
setPKCode(list(pkcall=call.command, pklist=call.final))
setPKGGobi(list(x=myx, y=NULL))
#Scatterplot matrix of ETAs:
newstr <- "Scatterplot matrix of ETAs"
plotType <- "smatrix"
tmp.data <- pkdata[c(myterm)]
# TODO
currentPage <- svalue(pk.dialog.notebook)
if (ncol(tmp.data) > 1)
{
pgraph = ggraphics(ps=6)
add(pk.dialog.notebook, pgraph, label = newstr,
#pageno = 3,
override.closebutton = TRUE)
call.command <- "matrix"
call.final <- getPKMatrixplotCall(hist.graphics= svalue(.$savewd[["graphics"]]), tmp.data)
print(call.final)
setPKCode(list(pkcall=call.command, pklist=call.final))
setPKGGobi(list(x=colnames(tmp.data), y=NULL))
}
}
################################################################################
## Menu "Model validation"
################################################################################
psn.outlier.okButtonHandler = function(.,h,...)
{
file1 <- svalue(.$widgets[["Result file:"]])
file2 <- svalue(.$widgets[["Deleted ID file:"]])
if (file1!="" && file2!="")
{
checkdata <- psn.cdd(file1, file2)
if (is.null(checkdata))
{
ErrorMessage("Two files are not right format for PsN!")
return(invisible(NULL))
}
mydata <- data.frame(checkdata)
## TODO: what does this function for?
#setValidateData(mydata)
message <- "PsN summary for influence analysis"
pgraph = ggraphics(ps=6)
add(pk.dialog.notebook, pgraph, label = message,
override.closebutton = TRUE)
if (svalue(.$savewd[["graphics"]]) == "lattice")
{
call.final <- xyplot(cov.ratios~cook.scores, data= mydata,
groups=ID,
type="l",
xlab="Cook.scores",
ylab="Cov.ratios",
main="",
panel= function(x, y,groups, subscripts, ...)
{
panel.xyplot(x, y, groups = groups, subscripts = subscripts, ...)
panel.text(x, y, groups[subscripts])
}
)
}
else
{
call.final <- qplot(cook.scores, cov.ratios, data = mydata, label = ID,
geom=c("point", "text")) + xlab("Cook.scores") + ylab("Cov.ratios")
}
print(call.final)
call.command <- "xyplot"
setPKCode(list(pkcall=call.command, pklist=call.final))
currentPage <- svalue(pk.dialog.notebook)
setDataSpecialPlot(mydata, as.character(currentPage))
}
else
ErrorMessage("Please choose proper files first!")
}
vis.outlier.okButtonHandler = function(.,h,...)
{
target.dirpath <- svalue(.$widgets[["Target directory path:"]])
sim.pattern <- svalue(.$widgets[["Simulation folder pattern:"]])
startFileName <- svalue(.$widgets[["NONMEM result file name:"]])
cond.var <- svalue(.$widgets[["Plot variable:"]])
id.var <- svalue(.$widgets[["Patient ID:"]])
rowLabel <- "resampleID"
if (target.dirpath=="" || sim.pattern=="" || startFileName=="")
{
ErrorMessage("Please input all parameters first!")
return(invisible(NULL))
}
# match the current data set
currentPage <- svalue(pmg.dialog.notebook)
total.id <- unique(getCurrentData(currentPage)[[id.var]])
final.df <- data.frame(ID=total.id)
if (cond.var==id.var)
{
ErrorMessage("You can NOT have same variable for both Patient ID and Plot variable!")
return(invisible(NULL))
}
if (target.dirpath!="")
{
## start process bar
convertW = gwindow(title="Processing...", parent=c(150,200), height=getSubHeight()*0.05, width=getSubWidth()*0.5, horizontal=FALSE)
convert.group =ggroup(horizontal=FALSE, spacing=0, expand=TRUE)
convert.bar <- gtkProgressBar()
add(convert.group, convert.bar)
add(convertW, convert.group)
# start with something
gtkProgressBarSetFraction(convert.bar, 0.2)
cdd.list <- extractCddData(target.dirpath, sim.pattern, startFileName, id.var, cond.var, total.id, rowLabel)
if (is.null(cdd.list))
{
dispose(convertW)
return(invisible(NULL))
}
gtkProgressBarSetFraction(convert.bar, 0.7)
extract.data <- cdd.list$data
extract.data <- data.frame(extract.data)
v.delete.id <- cdd.list$deleteID
final.para <- extract.data
####################################
## plot
# plot 1 ---------- Patient ID deletion plot
if (length(v.delete.id) == length(total.id))
{
mydata1 <- data.frame(deleteID=v.delete.id, runID=total.id)
## parallel plot
message <- "Patient ID deletion plot"
pgraph = ggraphics(ps=6)
add(pk.dialog.notebook, pgraph, label = message,
override.closebutton = TRUE)
call.command <- "xyplot"
myy <- "deleteID"
myx <- "runID"
if (svalue(.$savewd[["graphics"]]) == "lattice")
{
call.final <- xyplot(deleteID~runID, main="Patient ID deletion plot for case deletion diagnostics",
xlab= "Case deletion run ID", ylab="Deleted ID", type=c("p", "l"),
data=mydata1)
}
else
{
call.final <- qplot(runID, deleteID, main="Patient ID deletion plot for case deletion diagnostics",
xlab= "Case deletion run ID", ylab="Deleted ID",
geom=c("point", "line"),data=mydata1)
}
print(call.final)
setPKCode(list(pkcall=call.command, pklist=call.final))
currentPage <- svalue(pk.dialog.notebook)
setDataSpecialPlot(mydata1, as.character(currentPage))
# setGGobi
}
# plot 2 ---------- histogram
boot.all <- NULL
resampleID.all <- NULL
id.all <- NULL
sapply(1:ncol(extract.data), function(i)
{
#miss.id <- which(! id.unique %in% boot.data[,i])
boot.all <<- c(boot.all, extract.data[,i])
resampleID.all <<- c(resampleID.all, rep(i, nrow(extract.data)))
id.all <<- c(id.all, rownames(extract.data))
invisible(NULL)
})
boot.df <- data.frame(ID=id.all, resampleID=resampleID.all, para=boot.all)
message <- "Grouped by patient ID"
pgraph = ggraphics(ps=6)
add(pk.dialog.notebook, pgraph, label = message,
override.closebutton = TRUE)
if (svalue(.$savewd[["graphics"]]) == "lattice")
{
call.final <- densityplot(~para, groups=ID,
data=boot.df, main="grouped by patient ID", xlab=cond.var)
}
else
{
call.final <- ggplot(boot.df, aes(para)) + stat_density(geom = "path",
position = "identity", aes(colour = factor(ID)))
}
print(call.final)
call.command <- "densityplot"
setPKCode(list(pkcall=call.command, pklist=call.final))
currentPage <- svalue(pk.dialog.notebook)
setDataSpecialPlot(boot.df, as.character(currentPage))
message <- "Grouped by case deletion run ID"
pgraph = ggraphics(ps=6)
add(pk.dialog.notebook, pgraph, label = message,
override.closebutton = TRUE)
if (svalue(.$savewd[["graphics"]]) == "lattice")
{
call.final <- densityplot(~para, groups=resampleID, data=boot.df,
main="grouped by case deletion run ID", xlab=cond.var)
}
else
{
call.final <- ggplot(boot.df, aes(para)) + stat_density(geom = "path",
position = "identity", aes(colour = factor(resampleID))) + xlab(cond.var)
}
print(call.final)
call.command <- "densityplot"
setPKCode(list(pkcall=call.command, pklist=call.final))
currentPage <- svalue(pk.dialog.notebook)
setDataSpecialPlot(boot.df, as.character(currentPage))
gtkProgressBarSetFraction(convert.bar, 0.8)
# plot 3 ---------- parallel coor plot
message <- "Parallel coordinate plot"
pgraph = ggraphics(ps=6)
add(pk.dialog.notebook, pgraph, label = message,
override.closebutton = TRUE)
scale.data <- rbind(extract.data, min(extract.data, na.rm=T), max(extract.data, na.rm=T))
call.final <- parallel(~scale.data, main="bounded by global min and max", ylab="Case deletion ID")
call.command <- "parallel"
setPKCode(list(pkcall=call.command, pklist=call.final))
currentPage <- svalue(pk.dialog.notebook)
setDataSpecialPlot(scale.data, as.character(currentPage))
if (svalue(.$savewd[["graphics"]]) != "lattice")
{
scale.data <- namerows(scale.data, col.name = "ID")
df <- melt(scale.data[-10], id.var = c("ID"))
dfm <- ddply(df, .(variable), transform, rng = rescaler(value,
type = "range"))
call.final <- ggplot(dfm, aes(group = ID, colour = factor(ID))) +
geom_line(aes(variable, rng)) + xlab("Case deletion ID")+
coord_flip()
}
print(call.final)
gtkProgressBarSetFraction(convert.bar, 0.9)
# plot 4 ---------- MDS plot
e2.data <- t(extract.data)
#colnames(e2.data) <- 1:ncol(e2.data)
#parallel(~e2.data)
mydata <- e2.data
d <- dist(mydata) # euclidean distances between the rows
fit <- cmdscale(d,eig=TRUE, k=2) # k is the number of dim
fit # view results
# plot solution
x <- fit$points[,1]
y <- fit$points[,2]
message <- "Metric MDS"
pgraph = ggraphics(ps=6)
add(pk.dialog.notebook, pgraph, label = message,
override.closebutton = TRUE)
#call.final <- xyplot(x, y, xlab="Coordinate 1", ylab="Coordinate 2",
# main="Metric MDS", type="n")
#print(call.final)
#call.text <- text(x, y, labels = row.names(mydata), cex=.7)
#print(call.text)
#NOTE: NEED TO UPDATE -- "SIM" with proper one
mydata2 <- data.frame(cor1=x, cor2=y, resampleID=gsub(rowLabel, "", names(x)))
if (svalue(.$savewd[["graphics"]]) == "lattice")
{
call.final <- xyplot(cor2~cor1, data= mydata2,
groups=resampleID,
type="l",
xlab="Coordinate 1",
ylab="Coordinate 2",
main="Metric MDS",
panel= function(x, y,groups, subscripts, ...)
{
panel.xyplot(x, y, groups = groups, subscripts = subscripts, ...)
panel.text(x, y, groups[subscripts])
}
)
}
else
{
call.final <- qplot(cor1, cor2, data = mydata2, label = resampleID,
geom=c("point", "text")) + xlab("Coordinate 1") + ylab("Coordinate 2")
}
print(call.final)
call.command <- "xyplot"
setPKCode(list(pkcall=call.command, pklist=call.final))
currentPage <- svalue(pk.dialog.notebook)
setDataSpecialPlot(mydata2, as.character(currentPage))
## interactive graphics data
ig.data <- merge(boot.df, mydata2, by="resampleID")
ig.data <- ig.data[,c("resampleID", "para", "ID", "cor1", "cor2")]
ig.data$resampleID <- factor(ig.data$resampleID)
currentPage <- length(getNameDataSpecialPlot()) + 1
setDataSpecialPlot(ig.data, as.character(currentPage))
gtkProgressBarSetFraction(convert.bar, 1.0)
dispose(convertW)
}
}
psn.bootstrap.vis.okButtonHandler = function(.,h,...)
{
target.dirpath <- svalue(.$widgets[["Target directory path:"]])
sim.pattern <- svalue(.$widgets[["Bootstrap folder pattern:"]])
startFileName <- svalue(.$widgets[["NONMEM result file name:"]])
boot.key.path <- svalue(.$widgets[["Bootstrap key table path:"]])
boot.key.name <- svalue(.$widgets[["Bootstrap key table name:"]])
cond.var <- svalue(.$widgets[["Plot variable:"]])
id.var <- svalue(.$widgets[["Patient ID:"]])
rowLabel <- "resampleID"
if (target.dirpath=="" || sim.pattern=="" || startFileName=="" || boot.key.path=="" || boot.key.name=="")
{
ErrorMessage("Please input all parameters first!")
return(invisible(NULL))
}
# match the current data set
currentPage <- svalue(pmg.dialog.notebook)
total.id <- unique(getCurrentData(currentPage)[[id.var]])
final.df <- data.frame(ID=total.id)
if (cond.var==id.var)
{
ErrorMessage("You can NOT have same variable for both Patient ID and Plot variable!")
return(invisible(NULL))
}
if (Sys.info()[["sysname"]] == "Windows")
{
check.bootkey <- try(bootKey.table <- read.csv(paste(boot.key.path, boot.key.name, sep="\\"), header=F))
}
else
{
check.bootkey <- try(bootKey.table <- read.csv(paste(boot.key.path, boot.key.name, sep="/"), header=F))
}
if (inherits(check.bootkey, "try-error"))
{
ErrorMessage("Bootstrap key table can NOT be read!")
return(invisible(NULL))
}
## start process bar
convertW = gwindow(title="Processing...", parent=c(150,200), height=getSubHeight()*0.05, width=getSubWidth()*0.5, horizontal=FALSE)
convert.group =ggroup(horizontal=FALSE, spacing=0, expand=TRUE)
convert.bar <- gtkProgressBar()
add(convert.group, convert.bar)
add(convertW, convert.group)
# start with something
gtkProgressBarSetFraction(convert.bar, 0.2)
ori.data <- extractBootData(target.dirpath, sim.pattern, startFileName, id.var, cond.var, bootKey.table, total.id, 1)
if (is.null(ori.data))
{
dispose(convertW)
return(invisible(NULL))
}
extract.data <- data.frame(ori.data)
gtkProgressBarSetFraction(convert.bar, 0.7)
# dat prepare for bootstrap number
boot.all <- NULL
resampleID.all <- NULL
id.all <- NULL
sapply(1:ncol(extract.data), function(i)
{
#miss.id <- which(! id.unique %in% boot.data[,i])
boot.all <<- c(boot.all, extract.data[,i])
resampleID.all <<- c(resampleID.all, rep(i, nrow(extract.data)))
id.all <<- c(id.all, rownames(extract.data))
invisible(NULL)
})
boot.df <- data.frame(ID=id.all, resampleID=resampleID.all, para=boot.all)
####################################
## plot
# plot 1 ---------- Patient ID deletion plot
# ---------- Bootstrap randomization - patient ID deletion plot
deleted.df <- unique(boot.df[is.na(boot.df$para),][,c(1,2)])
choose.df <- unique(boot.df[!is.na(boot.df$para),][,c(1,2)])
message <- "Resampling design"
pgraph = ggraphics(ps=6)
add(pk.dialog.notebook, pgraph, label = message,
override.closebutton = TRUE)
if (svalue(.$savewd[["graphics"]]) == "lattice")
{
call.final <- xyplot(resampleID~ID, data=choose.df, type="p", xlab="Bootstrap ID",
main="Bootstrap randomization check")
}
else
{
call.final <- qplot(ID, resampleID, data=choose.df, geom=c("point"), xlab="Bootstrap ID",
main="Bootstrap randomization check")
}
print(call.final)
call.command <- "xyplot"
setPKCode(list(pkcall=call.command, pklist=call.final))
currentPage <- svalue(pk.dialog.notebook)
setDataSpecialPlot(choose.df, as.character(currentPage))
gtkProgressBarSetFraction(convert.bar, 0.8)
message <- "grouped by bootstrap run ID"
pgraph = ggraphics(ps=6)
add(pk.dialog.notebook, pgraph, label = message,
override.closebutton = TRUE)
if (svalue(.$savewd[["graphics"]]) == "lattice")
{
call.final <- densityplot(~para, groups=resampleID, data=boot.df,
main="grouped by bootstrap run ID", xlab=cond.var )
}
else
{
call.final <- ggplot(boot.df, aes(para)) + stat_density(geom = "path",
position = "identity", aes(colour = factor(resampleID))) + xlab(cond.var)
}
print(call.final)
call.command <- "densityplot"
setPKCode(list(pkcall=call.command, pklist=call.final))
currentPage <- svalue(pk.dialog.notebook)
setDataSpecialPlot(boot.df, as.character(currentPage))
gtkProgressBarSetFraction(convert.bar, 0.9)
## plot n ------------- rank boostrap variability
extract.var <- NULL
sapply(1:nrow(extract.data), function(i)
{
extract.var <<- c(extract.var, var(unlist(extract.data[i,]), na.rm=T))
invisible(NULL)
})
var.df <- data.frame(ID=order(total.id), VAR=extract.var)
var.plot <- var.df[order(var.df$VAR),]
var.plot$ID <- factor(var.plot$ID, levels= var.plot$ID)
message <- "variability of parameters for ordered ID"
pgraph = ggraphics(ps=6)
add(pk.dialog.notebook, pgraph, label = message,
override.closebutton = TRUE)
if (svalue(.$savewd[["graphics"]]) == "lattice")
{
call.final <- xyplot(VAR~ID, data=var.plot, xlab= "Ordered ID" ,
ylab= paste("Variance of ", cond.var, sep=""))
}
else
{
call.final <- qplot(ID, VAR, data=var.plot,xlab= "Ordered ID" ,
ylab= paste("Variance of ", cond.var, sep=""))
}
print(call.final)
call.command <- "xyplot"
setPKCode(list(pkcall=call.command, pklist=call.final))
currentPage <- svalue(pk.dialog.notebook)
setDataSpecialPlot(var.plot, as.character(currentPage))
currentPage <- length(getNameDataSpecialPlot()) + 1
setDataSpecialPlot(var.plot, as.character(currentPage))
#currentPage <- as.numeric(svalue(pk.dialog.notebook))
#sapply(1:currentPage, function(i)
#{
# setDataSpecialPlot(var.plot, as.character(i))
#})
gtkProgressBarSetFraction(convert.bar, 1.0)
dispose(convertW)
}
## Code modified from PsN
psn.bootstrap.sum.okButtonHandler = function(.,h,...)
{
while (svalue(pk.dialog.notebook) > 1)
{
dispose(pk.dialog.notebook)
}
file1 <- svalue(.$widgets[["PsN result file:"]])
file2 <- svalue(.$widgets[["Bootstrap key file:"]])
min.failed <- FALSE # do we want to omit minimization failed runs?
cov.failed <- FALSE # do we want to omit covariance failed runs?
cov.warnings <- TRUE # do we want to omit covariance failed runs?
boundary <- TRUE # do we want to omit boundary runs?
showoriginal <- TRUE # show line for original estimate
showmean <- TRUE # show line for mean
showmedian <- FALSE # show line for median
show95CI <- TRUE # show line for 95 % confidence interval (percentile)
showquart <- FALSE # show line for quartiles
excl.id <- c() # exclude samples that have this individual
## read files
b.try1 <- try(bootstrap.data <- read.csv(file1, header=T)) # read.csv("raw_results1.csv", header=T)
in.try2 <- try(incl.ids <- read.csv(file2, header=F)) # read.csv("included_individuals1.csv", header=F)
if (inherits(b.try1, "try-error") || inherits(in.try2, "try-error"))
{
ErrorMessage("PsN result file or key file can NOT be read!")
return(invisible(NULL))
}
check.col <- c("minimization_successful", "covariance_step_successful",
"covariance_step_warnings", "estimate_near_boundary")
if (!all(check.col %in% names(bootstrap.data)))
{
ErrorMessage("PsN result file or key file can NOT be read!")
return(invisible(NULL))
}
## replace underscores
for (i in 1:length(names(bootstrap.data))) {
names(bootstrap.data)[i] <- gsub("_", ".", names(bootstrap.data)[i])
}
## find ofv column index
index <- 0
seen <- FALSE
for (i in names(bootstrap.data)) {
if (!seen) {
index <- index + 1
}
if (i == "ofv") {
seen <- TRUE
}
}
## get number of parameters
n <-