Nothing
# ----------------------------------------------------------
# Authors: Andreas Alfons, Bernd Prantner and Matthias Templ
# Vienna University of Technology
# ----------------------------------------------------------
#' GUI for Visualization and Imputation of Missing Values
#'
#' Graphical user interface for visualization and imputation of missing values.
#'
#' The \emph{Data} menu allows to select a data set from the workspace or load
#' data into the workspace from \code{RData} files. Furthermore, it can be
#' used to transform variables, which are then appended to the data set in use.
#' Commonly used transformations in official statistics are available, e.g.,
#' the Box-Cox transformation and the log-transformation as an important
#' special case of the Box-Cox transformation. In addition, several other
#' transformations that are frequently used for compositional data are
#' implemented. Background maps and coordinates for spatial data can be
#' selected in the data menu as well.
#'
#' After a data set was chosen, variables can be selected in the main menu,
#' along with a method for scaling. An important feature is that the variables
#' will be used in the same order as they were selected, which is especially
#' useful for parallel coordinate plots. Variables for highlighting are
#' distinguished from the plot variables and can be selected separately. For
#' more than one variable chosen for highlighting, it is possible to select
#' whether observations with missing values in any or in all of these variables
#' should be highlighted.
#'
#' A plot method can be selected from the \emph{Visualization} menu. Note that
#' plots that are not applicable to the selected variables are disabled, for
#' example, if only one plot variable is selected, multivariate plots cannot be
#' chosen.
#'
#' The \emph{Imputation} menu offers robust imputation methods to impute
#' variables of the data set.
#'
#' The \emph{Diagnostics} menu is similar to the \emph{Visualization} menu, but
#' is designed to verify the results after the imputation of missing values.
#'
#' Last, but not least, the \emph{Options} menu allows to set the colors, alpha
#' channel and the delimiter for imputed variables to be used in the plots. In
#' addition, it contains an option to embed multivariate plots in \code{Tcl/Tk}
#' windows. This is useful if the number of observations and/or variables is
#' large, because scrollbars allow to move from one part of the plot to
#' another.
#'
#' Internal information regarding the VIM GUI is stored in the environment
#' \code{vmGUIenvir}.
#'
#' @aliases vmGUImenu vmGUIenvir
#' @author Andreas Alfons, based on an initial design by Matthias Templ,
#' modifications by Bernd Prantner
#' @references M. Templ, A. Alfons, P. Filzmoser (2012) Exploring incomplete
#' data using visualization tools. \emph{Journal of Advances in Data Analysis
#' and Classification}, Online first. DOI: 10.1007/s11634-011-0102-y.
#' @references A. Kowarik, M. Templ (2016) Imputation with
#' R package VIM. \emph{Journal of
#' Statistical Software}, 74(7), 1-16
#' @keywords multivariate hplot
#' @export vmGUImenu
vmGUImenu <- function() {
## VisualizationMenunitializations
# retrieve values of internal variables if they exist
activeDataSet <- if(existsVm("activeDataSet")) ActiveDataSet() else ""
vars <- if(existsVm("vars")) getVm("vars") else character()
imp_vars <- if(existsVm("imp_vars")) getVm("imp_vars") else character()
scaling <- if(existsVm("scaling")) getVm("scaling") else "none"
highlight <- if(existsVm("highlight")) getVm("highlight") else character()
selection <- if(existsVm("selection")) getVm("selection") else "any"
tvars <- if(existsVm("tvars")) getVm("tvars") else character()
transform <- if(existsVm("transform")) getVm("transform") else ""
alrVar <- if(existsVm("alrVar")) getVm("alrVar") else ""
map <- if(existsVm("map")) getVm("map") else ""
coords <- if(existsVm("coords")) getVm("coords") else rep("", 2)
region <- if(existsVm("region")) getVm("region") else ""
loadPreferences() # load preferences from file
col <- if(existsVm("col")) getVm("col")
else c("skyblue","red","skyblue4","red4","orange","orange4")
alpha <- if(existsVm("alpha")) getVm("alpha") else 0.6
tkr <- if(existsVm("tkr")) getVm("tkr") else FALSE
delimiter <- if(existsVm("delimiter")) getVm("delimiter") else "_imp"
# save initial values in environment
ActiveDataSet(activeDataSet)
putVm("vars", vars)
putVm("imp_vars", imp_vars)
putVm("scaling", scaling)
putVm("highlight", highlight)
putVm("selection", selection)
putVm("tvars", tvars)
putVm("transform", transform)
putVm("alrVar", alrVar)
putVm("map", map)
putVm("coords", coords)
putVm("region", region)
putVm("col", col)
putVm("alpha", alpha)
putVm("tkr", tkr)
putVm("delimiter", delimiter)
## function to set state of menu items ("normal" or "disabled")
activateMenus <- function() {
## top menu
state <- checkVarsS()
for(i in 2:4)
.Tcl(paste(topMenu$ID, "entryconfigure", i, "-state", state))
## data menu
.Tcl(paste(DataMenu$ID, "entryconfigure", 2,
"-state", checkActiveDataS()))
.Tcl(paste(DataMenu$ID, "entryconfigure", 3,
"-state", checkActiveDataS()))
## visualization and imputation menu
# uni- and bivariate plots
state <- checkUnivarS()
for(i in 1:6) {
.Tcl(paste(VisualizationMenu$ID, "entryconfigure", i,
"-state", state))
.Tcl(paste(DiagnosticsMenu$ID, "entryconfigure", i,
"-state", state))
}
state <- checkBivarS()
for(i in 7:9) {
.Tcl(paste(VisualizationMenu$ID, "entryconfigure", i,
"-state", state))
.Tcl(paste(DiagnosticsMenu$ID, "entryconfigure", i,
"-state", state))
}
# multivariate plots
state <- checkMultivarS()
for(i in 10:14) {
.Tcl(paste(VisualizationMenu$ID, "entryconfigure", i,
"-state", state))
.Tcl(paste(DiagnosticsMenu$ID, "entryconfigure", i,
"-state", state))
}
# maps
state <- checkMapS()
.Tcl(paste(VisualizationMenu$ID, "entryconfigure", 15,
"-state", state))
.Tcl(paste(DiagnosticsMenu$ID, "entryconfigure", 15,
"-state", state))
state <- checkGrowdotS()
.Tcl(paste(VisualizationMenu$ID, "entryconfigure", 16,
"-state", state))
.Tcl(paste(DiagnosticsMenu$ID, "entryconfigure", 16,
"-state", state))
state <- checkColormapS()
.Tcl(paste(VisualizationMenu$ID, "entryconfigure", 17,
"-state", checkColormapS()))
.Tcl(paste(DiagnosticsMenu$ID, "entryconfigure", 17,
"-state", state))
}
## functions bound to top menu buttons
# close GUI
# ----------
# comment during development
Quit <- function() {
yesno <- tkmessageBox(message=paste("Close GUI for visualization",
"and imputation of missing values?"), icon="question",
type="yesno", default="no", parent=ttM, title="Quit")
if(tclvalue(yesno) == "yes") {
savePreferences()
closeDialog(ttM)
rmVm(".ttM")
}
}
# ----------
# during development replaced by following function that quits immediately
# (to save time)
# Quit <- function() {
# savePreferences()
# closeDialog(ttM)
# rmVm(".ttM")
# }
# ----------
# not implemented yet
NotImplemented <- function() {
tkmessageBox(message="Not implemented yet.", icon="error", parent=ttM)
}
## functions bound to data menu buttons
# select active data set
vmGUIdata <- function() {
# start dialog
ttD <- initializeDialog("Select Data")
# initializations
activeDataSet <- ActiveDataSet()
putVm(".activeDataSet", activeDataSet)
dataSets <- getDataSets()
# listbox
dataFrame <- tkwidget(ttD, "labelframe",
text="Select Data", fg="blue")
dataBox <- listbox(dataFrame, variables=dataSets,
initial=activeDataSet, height=6)
setData <- function() {
selDataSet <- getSelection(dataBox, variables=dataSets)
putVm(".activeDataSet", selDataSet)
activateOK()
}
bind(dataBox, setData)
# ok and cancel buttons
onOK <- function() {
selDataSet <- getVm(".activeDataSet")
if(selDataSet != activeDataSet) {
# get imputed variables
delimiter <- getVm("delimiter")
vars <- colnames(get(selDataSet, envir=.GlobalEnv))
imp_vars <- grep(delimiter, colnames(get(selDataSet, envir=.GlobalEnv)), value = TRUE)
vars <- setdiff(vars, imp_vars)
ActiveDataSet(selDataSet)
putVm("vars", character())
putVm("highlight", character())
putVm("imp_vars", imp_vars)
putVm("coords", rep("", 2))
putVm("region", "")
activateElements()
activateMenus()
empty(varsBox)
deselectAll(varsButtons)
insert(varsBox, vars)
empty(highlightBox)
deselectAll(highlightButtons)
insert(highlightBox, vars)
}
closeDialog(ttD, parent=ttM)
}
buttons <- okCancel(ttD, onOK, parent=ttM)
activateOK <- function() {
okS <- if(nchar(getVm(".activeDataSet"))) "normal" else "disabled"
setState(buttons, okS)
}
# display dialog elements
tkpack(dataBox$frame, expand=TRUE,
fill="x", padx=3, pady=3, side="left")
tkgrid(dataFrame, padx=10, pady=5, sticky="news")
tkgrid(buttons$frame)
activateOK()
}
# load R data
LoadRData <- function() {
fileName <- tclvalue(tkgetOpenFile(parent=ttM, title="Load R Data",
filetypes=paste("{{R Data Files} {.RData .Rdata .rdata .rda}}",
"{{All files} *}")))
if(nchar(fileName)) {
nam <- try(load(fileName, envir=.GlobalEnv))
if(!inherits(class(nam), "try-error")) {
dataSet <- getDataSets(nam)
if(length(dataSet) == 0) {
msg <- "File '%s' does not contain a data set.\n"
tkmessageBox(message=gettextf(msg, fileName),
icon="error", parent=ttM)
} else if(length(dataSet) == 1) {
if(dataSet != ActiveDataSet()) {
# get imputed variables
delimiter <- getVm("delimiter")
vars <- colnames(get(dataSet, envir=.GlobalEnv))
imp_vars <- grep(delimiter, colnames(get(dataSet, envir=.GlobalEnv)), value = TRUE)
vars <- setdiff(vars, imp_vars)
ActiveDataSet(dataSet)
putVm("vars", character())
putVm("highlight", character())
putVm("coords", rep("", 2))
putVm("region", "")
activateElements()
activateMenus()
empty(varsBox)
deselectAll(varsButtons)
insert(varsBox, vars)
empty(highlightBox)
deselectAll(highlightButtons)
insert(highlightBox, vars)
}
} else {
msg <- paste("File '%s' contains more than one data set.",
"Please select one using '%s'.\n")
tkmessageBox(message=gettextf(msg, fileName, "Select Data"),
icon="warning", parent=ttM)
}
}
}
}
# transform variables
vmGUItransform <- function() {
# start dialog
ttT <- initializeDialog("Transform Variables")
# initializations
allVars <- getVars()
tvars <- getVm("tvars")
transform <- getVm("transform")
alrVar <- getVm("alrVar")
putVm(".tvars", tvars)
putVm(".transform", transform)
putVm(".alrVar", alrVar)
# frames
topFrame <- tkframe(ttT)
tvarsFrame <- tkwidget(topFrame, "labelframe",
text="Select Variables", fg="blue")
transformFrame <- tkwidget(topFrame, "labelframe",
text="Select Transformation", fg="blue")
## left side
# listbox for variables
tvarsBox <- listbox(tvarsFrame, initial=tvars,
height=12, selectmode="extended")
setTvars <- function() {
tvars <- getSelection(tvarsBox)
putVm(".tvars", tvars)
deselectAll(tvarsButtons)
activateElements()
}
bind(tvarsBox, setTvars)
# select and deselect all variables radiobuttons
tvarsButtons <- radiobuttons(tvarsFrame,
buttons=c("tvarsSelectAll","tvarsDeselectAll"),
labels=c("Select all","Deselect all"))
tvarsSelectAll <- function() {
putVm(".tvars", allVars)
selectAll(tvarsBox)
activateElements()
}
tvarsDeselectAll <- function() {
putVm(".tvars", character())
deselectAll(tvarsBox)
activateElements()
}
bind(tvarsButtons, tvarsSelectAll, "tvarsSelectAll")
bind(tvarsButtons, tvarsDeselectAll, "tvarsDeselectAll")
tkpack(tvarsBox$frame, tvarsButtons$frame,
expand=TRUE, fill="x", padx=3, pady=3, side="left")
## right side
# radiobuttons for transformation
transformButtons <- radiobuttons(transformFrame,
buttons=c("minus","reciprocal","logarithm",
"exponential","boxcox","clr","ilr","alr"),
labels=c("Minus","Reciprocal","Logarithm","Exponential",
"Box-Cox","Centered logratio","Isometric logratio",
"Additive logratio with ratio variable"),
initial=transform)
setTransform <- function() {
transform <- getSelection(transformButtons)
putVm(".transform", transform)
activateElements()
}
bind(transformButtons, setTransform)
# ratio variable for logratio transformation
alrVariable <- tclVar(alrVar)
setAlrVar <- function() {
tkfocus(ttT)
putVm(".alrVar", tclvalue(alrVariable))
activateElements()
}
alrComboBox <- tkwidget(transformButtons$frame, "ComboBox",
"-modifycmd", setAlrVar, editable=FALSE, values=allVars,
width=15, textvariable=alrVariable)
tkgrid(alrComboBox, row=8, column=1, sticky="w")
tkpack(transformButtons$frame, expand=TRUE,
fill="x", padx=3, pady=3, side="left")
# ok and cancel buttons
onOK <- function() {
tvars <- getVm(".tvars")
putVm("tvars", tvars)
transform <- getVm(".transform")
putVm("transform", transform)
activeData <- get(ActiveDataSet(), envir=.GlobalEnv)
if(transform == "alr") {
alrVar <- getVm(".alrVar")
putVm("alrVar", alrVar)
x <- subset(activeData, select=union(tvars, alrVar))
tx <- prepare(x, transformation=transform, alrVar=alrVar)
colnames(tx) <- paste("alr(", colnames(tx), ")", sep="")
} else {
x <- subset(activeData, select=tvars)
tx <- prepare(x, transformation=transform)
}
if(transform == "minus") colnames(tx) <- paste("-", tvars, sep="")
else if(transform == "reciprocal")
colnames(tx) <- paste("1/", tvars, sep="")
else if(!(transform %in% c("ilr","alr"))){
prefix <- switch(transform,
logarithm="log", exponential="exp",
boxcox="boxcox", clr="clr")
colnames(tx) <- paste(prefix, "(", tvars, ")", sep="")
}
assign(ActiveDataSet(), cbind(activeData, tx), envir=vmGUIenv())
getVm("ActiveDataSet()")
insert(varsBox, colnames(tx))
insert(highlightBox, colnames(tx))
closeDialog(ttT, parent=ttM)
}
# ok and cancel buttons
buttons <- okCancel(ttT, onOK, parent=ttM)
activateElements <- function() {
tvars <- getVm(".tvars")
transform <- getVm(".transform")
alrVar <- getVm(".alrVar")
checkTvars <- length(tvars)
transformS <- if(checkTvars) "normal" else "disabled"
logratioS <- if(length(tvars) > 1) "normal" else "disabled"
setState(transformButtons, transformS,
which=setdiff(names(transformButtons$buttons), c("clr","ilr")))
setState(transformButtons, logratioS, which=c("clr","ilr"))
checkAlr <- checkTvars && transform == "alr"
alrS <- if(checkAlr) "normal" else "disabled"
tkconfigure(alrComboBox, state=alrS)
checkOK <-
if(transform %in% c("clr","ilr")) length(tvars) > 1
else if(transform == "alr")
nchar(alrVar) && length(union(tvars, alrVar)) > 1
else length(tvars) && nchar(transform)
okS <- if(checkOK) "normal" else "disabled"
setState(buttons, okS)
}
# display dialog elements
tkpack(tvarsFrame, fill="y", padx=10, pady=5, side="left")
tkpack(transformFrame, fill="y", padx=10, pady=5, side="right")
tkpack(topFrame, side="top")
tkpack(buttons$frame, side="bottom")
activateElements()
}
# background map
vmGUImap <- function() {
# start dialog
ttMap <- initializeDialog("Background Map")
# initializations
map <- getVm("map")
coords <- getVm("coords")
region <- getVm("region")
putVm(".map", map)
putVm(".coords", coords)
putVm(".region", region)
topFrame <- tkframe(ttMap)
## left side
# background map
mapFrame <- tkwidget(topFrame, "labelframe",
text="Select Background Map", fg="blue")
maps <- ls(envir=.GlobalEnv)
mapBox <- listbox(mapFrame, variables=maps, initial=map, height=6)
setMap <- function() {
map <- getSelection(mapBox, variables=maps)
putVm(".map", map)
activateOK()
}
bind(mapBox, setMap)
tkpack(mapBox$frame, expand=TRUE, fill="x", padx=3, pady=3, side="left")
## right side
toprightFrame <- tkframe(topFrame)
# coordinates
coordsFrame <- tkwidget(toprightFrame, "labelframe",
text="Select Coordinates", fg="blue")
xyFrame <- tkframe(coordsFrame)
vars <- c("", getVars())
xVariable <- tclVar(coords[1])
yVariable <- tclVar(coords[2])
setCoords <- function() {
tkfocus(ttMap)
coords <- c(tclvalue(xVariable), tclvalue(yVariable))
putVm(".coords", coords)
activateOK()
}
xComboBox <- tkwidget(xyFrame, "ComboBox",
"-modifycmd", setCoords, editable=FALSE, values=vars,
width=15, textvariable=xVariable)
yComboBox <- tkwidget(xyFrame, "ComboBox",
"-modifycmd", setCoords, editable=FALSE, values=vars,
width=15, textvariable=yVariable)
tkgrid(tklabel(xyFrame, text="x-Coordinate: "), xComboBox, sticky="w")
tkgrid(tklabel(xyFrame, text="y-Coordinate: "), yComboBox, sticky="w")
tkgrid(xyFrame, padx=3, pady=3)
# region
regionFrame <- tkwidget(toprightFrame, "labelframe",
text="Set Region Variable", fg="blue")
rFrame <- tkframe(regionFrame)
regionVariable <- tclVar(region)
setRegion <- function() {
tkfocus(ttMap)
region <- tclvalue(regionVariable)
putVm(".region", region)
activateOK()
}
regionComboBox <- tkwidget(rFrame, "ComboBox",
"-modifycmd", setRegion, editable=FALSE, values=vars,
width=15, textvariable=regionVariable)
tkpack(tklabel(rFrame, text="Region: "), side="left")
tkpack(regionComboBox, side="right")
tkpack(rFrame, fill="x", padx=3, pady=3)
# ok and cancel buttons
onOK <- function() {
putVm("map", getVm(".map"))
putVm("coords", getVm(".coords"))
putVm("region", getVm(".region"))
activateMenus()
closeDialog(ttMap, parent=ttM)
}
buttons <- okCancel(ttMap, onOK, parent=ttM)
activateOK <- function() {
coords <- getVm(".coords")
ncCoords <- nchar(coords)
ok <- nchar(getVm(".map")) &&
if(any(ncCoords)) all(ncCoords) && coords[1] != coords[2]
else nchar(getVm(".region"))
okS <- if(ok) "normal" else "disabled"
setState(buttons, okS)
}
# display dialog elements
tkpack(mapFrame, fill="y", padx=10, pady=5, side="left")
tkpack(coordsFrame, fill="x", padx=10, pady=5, side="top")
tkpack(regionFrame, fill="x", padx=10, pady=5, side="bottom")
tkpack(toprightFrame, fill="y", side="right")
tkpack(topFrame, side="top")
tkpack(buttons$frame, side="bottom")
activateOK()
}
knnGUI <- function(){
onOKkNN <- function(){
data <- get(ActiveDataSet())
vars <- getVm("vars")
distance <- getVm("distance")
k <- getVm("k")
assign(paste(ActiveDataSet(),"_IMPUTED",sep=""),
kNN(data,variable=vars,dist_var=distance,k=k,
imp_suffix=getVm("delimiter")), envir=vmGUIenv()) #new
getVm(paste(ActiveDataSet(),"_IMPUTED",sep="")) #new
cmd <- paste(paste(ActiveDataSet(),"_IMPUTED",sep=""),
" <- kNN(",ActiveDataSet(),",variable=c(",paste("\"",vars,"\"",sep="",collapse=","),
"),dist_var=c(",paste("\"",distance,"\"",sep="",collapse=","),"),
k=",k,",imp_suffix=\"",getVm("delimiter"),"\")", sep="")
cat(cmd,"\n")
closeDialog(ttIMP)
}
ttIMP <- initializeDialog("kNN - Imputation")
## frames
varsFrame <- tkwidget(ttIMP, "labelframe",
text="Select Variables to impute", fg="blue")
distanceFrame <- tkwidget(ttIMP, "labelframe",
text="Select Variables to compute distances", fg="blue")
kFrame <- tkwidget(ttIMP, "labelframe",
text="Select the number of nearest neighbours", fg="blue")
## dialog elements
# listbox for plot variables
varsBox1 <- listbox(varsFrame, initial=vars,
height=6, selectmode="extended")
distanceBox1 <- listbox(distanceFrame,
initial=vars, height=6, selectmode="extended")
kBox1 <- listbox(kFrame,variables=1:10,
initial=2, height=6, selectmode="single")
# select and deselect all variables radiobuttons
# selection method for highlight variables
tkpack(varsBox1$frame,
expand=TRUE, fill="x", padx=3, pady=3, side="left")
tkpack(distanceBox1$frame,
expand=TRUE, fill="x", padx=3, pady=3, side="left")
tkpack(kBox1$frame,
expand=TRUE, fill="x", padx=3, pady=3, side="left")
tkgrid(varsFrame, padx=10, pady=5, sticky="news")
tkgrid(distanceFrame, padx=10, pady=5, sticky="news")
tkgrid(kFrame, padx=10, pady=5, sticky="news")
buttons <- okCancel(ttIMP, onOKkNN, parent=ttM)
tkgrid(buttons$frame)
setVars1 <- function() {
vars <- getSelection(varsBox1)
putVm("vars", vars)
}
setdistance <- function() {
distance <- getSelection(distanceBox1)
putVm("distance", distance)
}
setk <- function() {
k <- getSelection(kBox1,variables=1:10)
putVm("k", k)
}
bind(varsBox1, setVars1)
bind(kBox1, setk)
bind(distanceBox1, setdistance)
setVars1();setk();setdistance();
}
hotdeckGUI <- function(){
getVarsF <- function(){
vv <- vector()
for(v in getVars()){
x <- is.numeric(subset(get(ActiveDataSet(), envir=.GlobalEnv),select=v))
if(x)
vv <- c(vv,v)
}
vv
}
getVarsN <- function(){
vv <- vector()
for(v in getVars()){
x <- is.numeric(subset(get(ActiveDataSet(), envir=.GlobalEnv),select=v))
if(!x)
vv <- c(vv,v)
}
vv
}
onOKhotdeck <- function(){
data <- get(ActiveDataSet())
vars <- getVm("vars")
sort <- getVm("sort")
domain <- getVm("domain")
if(length(domain)<1)
domain <- NULL
if(length(sort)<1)
sort <- NULL
if(length(vars)<1){
tkmessageBox(message=c("Select at least one variable to impute!"),
icon="warning", parent=ttM)
}else{
assign(paste(ActiveDataSet(),"_IMPUTED",sep=""),
hotdeck(data,variable=vars,ord_var=sort,domain_var=domain,
imp_suffix=getVm("delimiter")), envir=vmGUIenv()) #new
getVm(paste(ActiveDataSet(),"_IMPUTED",sep="")) #new
if(is.null(sort))
ord_var <- "NULL"
else
ord_var <- paste("c(",paste("\"",sort,"\"",sep="",collapse=","),")",sep="")
if(is.null(domain))
domain_var <- "NULL"
else
domain_var <- paste("c(",paste("\"",domain,"\"",sep="",collapse=","),")",sep="")
cmd <- paste(paste(ActiveDataSet(),"_IMPUTED",sep=""),
" <- hotdeck(",ActiveDataSet(),",variable=c(",paste("\"",vars,"\"",sep="",collapse=","),
"),ord_var=",ord_var,",domain_var=",domain_var,",imp_suffix=\"",getVm("delimiter"),"\")",sep="")
cat(cmd,"\n")
}
closeDialog(ttIMP)
}
ttIMP <- initializeDialog("Hotdeck - Imputation")
## frames
varsFrame <- tkwidget(ttIMP, "labelframe",
text="Select Variables to impute", fg="blue")
sortFrame <- tkwidget(ttIMP, "labelframe",
text="Select Variables to sort", fg="blue")
domainFrame <- tkwidget(ttIMP, "labelframe",
text="Select Variables to build domains", fg="blue")
## dialog elements
# listbox for plot variables
varsBox1 <- listbox(varsFrame, initial=vars,
height=6, selectmode="extended")
sortBox1 <- listbox(sortFrame,variables=getVarsN(),
initial=NULL, height=6, selectmode="extended")
domainBox1 <- listbox(domainFrame,variables=getVarsF(),
initial=NULL, height=6, selectmode="extended")
# select and deselect all variables radiobuttons
# selection method for highlight variables
tkpack(varsBox1$frame,
expand=TRUE, fill="x", padx=3, pady=3, side="left")
tkpack(sortBox1$frame,
expand=TRUE, fill="x", padx=3, pady=3, side="left")
tkpack(domainBox1$frame,
expand=TRUE, fill="x", padx=3, pady=3, side="left")
tkgrid(varsFrame, padx=10, pady=5, sticky="news")
tkgrid(sortFrame, padx=10, pady=5, sticky="news")
tkgrid(domainFrame, padx=10, pady=5, sticky="news")
buttons <- okCancel(ttIMP, onOKhotdeck, parent=ttM)
tkgrid(buttons$frame)
setVars1 <- function() {
vars <- getSelection(varsBox1)
putVm("vars", vars)
}
setsort <- function() {
sort <- getSelection(sortBox1,variables=getVarsN())
putVm("sort", sort)
}
setdomain <- function() {
domain <- getSelection(domainBox1,variables=getVarsF())
putVm("domain", domain)
}
bind(varsBox1, setVars1)
bind(domainBox1, setdomain)
bind(sortBox1, setsort)
setVars1();setdomain();setsort();
}
irmiGUI <- function(){
getVarsN <- function(){
vv <- vector()
for(v in getVars()){
x <- is.numeric(subset(get(ActiveDataSet(), envir=.GlobalEnv),select=v))
if(!x)
vv <- c(vv,v)
}
vv
}
onOKirmi <- function(){
x <- subset(get(ActiveDataSet(), envir=.GlobalEnv),
select=getVm("vars"))
vars=getVm("vars")
mixed=getVm("mixed")
robust=getVm("robust")
assign(paste(ActiveDataSet(),"_IMPUTED",sep=""),
irmi(x,mixed=mixed,robust=robust), envir=vmGUIenv()) #new
getVm(paste(ActiveDataSet(),"_IMPUTED",sep="")) #new
if(length(mixed)>1)
mixed <- paste("c(",paste("\"",mixed,"\"",sep="",collapse=","),")",sep="")
else mixed <- "NULL"
cmd <-
paste(paste(ActiveDataSet(),"_IMPUTED",sep=""),
" <- irmi(",ActiveDataSet(),"[,c(",
paste("\"",vars,"\"",sep="",collapse=","),")],mixed=",
mixed,",robust=",robust,")"
,sep="")
cat(cmd,"\n")
closeDialog(ttIMP)
}
ttIMP <- initializeDialog("IRMI")
## frames
varsFrame <- tkwidget(ttIMP, "labelframe",
text="Select Variables to impute", fg="blue")
mixedFrame <- tkwidget(ttIMP, "labelframe",
text="Select semi-continous variables", fg="blue")
robustFrame <- tkwidget(ttIMP, "labelframe",
text="robust/non-robust", fg="blue")
# listbox for plot variables
varsBox1 <- listbox(varsFrame, initial=vars,
height=6, selectmode="extended")
mixedBox1 <- listbox(mixedFrame,variables=getVarsN(),
initial=NULL, height=6, selectmode="extended")
robustButtons <- radiobuttons(robustFrame,
buttons=c("robust","classical"),
labels=c("robust","classical"),initial="classical")
# select and deselect all variables radiobuttons
# selection method for highlight variables
tkpack(varsBox1$frame,
expand=TRUE, fill="x", padx=3, pady=3, side="left")
tkpack(mixedBox1$frame,
expand=TRUE, fill="x", padx=3, pady=3, side="left")
tkpack(robustButtons$frame,
expand=TRUE, fill="x", padx=3, pady=3, side="left")
tkgrid(varsFrame, mixedFrame,robustFrame, padx=10, pady=5, sticky="news")
buttons <- okCancel(ttIMP, onOKirmi, parent=ttM)
tkgrid(buttons$frame)
setVars1 <- function() {
vars <- getSelection(varsBox1)
putVm("vars", vars)
}
setmixed <- function() {
mixed <- getSelection(mixedBox1,variables=getVarsN())
putVm("mixed", mixed)
}
setrobust <- function(){
robust <- tclvalue(robustButtons$variable)=="robust"
putVm("robust", robust)
}
bind(varsBox1, setVars1)
bind(mixedBox1, setmixed)
bind(robustButtons,setrobust)
setVars1();setmixed(); setrobust();
}
## functions bound to visualization and diagnostic menu buttons
# aggregate missings
Aggr <- function() {
x <- subset(get(ActiveDataSet(), envir=.GlobalEnv),
select=getVm("vars"))
res <- aggr(x, plot=FALSE)
cat("\n\nPrint method:\n")
print(res)
cat("\n\nSummary method:\n")
print(summary(res))
cat("\n")
if(getVm("tkr")) {
TKRaggr(x, col=getVm("col")[1:2], numbers=TRUE, prop=c(TRUE, FALSE))
} else {
dev.new()
plot(res, col=getVm("col")[1:2], numbers=TRUE, prop=c(TRUE, FALSE))
}
}
# aggregate missings and imputed missings
AggrImp <- function() {
vars <- c(getVm("vars"), getVm("imp_vars"))
x <- subset(get(ActiveDataSet(), envir=.GlobalEnv),
select=vars)
res <- aggr(x, delimiter=getVm("delimiter"), plot=FALSE)
cat("\n\nPrint method:\n")
print(res)
cat("\n\nSummary method:\n")
print(summary(res))
cat("\n")
if(getVm("tkr")) {
TKRaggr(x, delimiter=getVm("delimiter"), col=getVm("col")[c(1,2,5)], numbers=TRUE, prop=c(TRUE, FALSE))
} else {
dev.new()
plot(res, col=getVm("col")[c(1,2,5)], numbers=TRUE, prop=c(TRUE, FALSE))
}
}
# histogram with missings
HistMiss <- function() {
vars <- union(getVm("vars"), getVm("highlight"))
x <- subset(get(ActiveDataSet(), envir=.GlobalEnv), select=vars)
x[,1] <- prepare(x[,1], scaling=getVm("scaling"))
dev.new()
histMiss(x, selection=getVm("selection"),
col=getVm("col"), xlab=getLabel(vars[1]))
#leg <- paste(c("observed in","missing in"), vars[2])
#legend("topleft", legend=leg, pch=15, col=col, pt.cex=1.5, bty="n")
}
# histogram with imputed missings
HistImp <- function() {
vars <- union(getVm("vars"), getVm("highlight"))
vars <- c(vars,getVm("imp_vars"))
x <- subset(get(ActiveDataSet(), envir=.GlobalEnv), select=vars)
x[,1] <- prepare(x[,1], scaling=getVm("scaling"))
dev.new()
histMiss(x, delimiter=getVm("delimiter"), selection=getVm("selection"),
col=getVm("col"), xlab=getLabel(vars[1]))
#leg <- paste(c("observed in","missing in"), vars[2])
#legend("topleft", legend=leg, pch=15, col=col, pt.cex=1.5, bty="n")
}
# spinogram with missings
SpinogramMiss <- function() {
vars <- union(getVm("vars"), getVm("highlight"))
x <- subset(get(ActiveDataSet(), envir=.GlobalEnv), select=vars)
x[,1] <- prepare(x[,1], scaling=getVm("scaling"))
dev.new()
spineMiss(x, selection=getVm("selection"),
col=getVm("col"), xlab=getLabel(vars[1]))
}
# spinogram with imputed missings
SpinogramImp <- function() {
vars <- union(getVm("vars"), getVm("highlight"))
vars <- c(vars,getVm("imp_vars"))
x <- subset(get(ActiveDataSet(), envir=.GlobalEnv), select=vars)
x[,1] <- prepare(x[,1], scaling=getVm("scaling"))
dev.new()
spineMiss(x, delimiter=getVm("delimiter"), selection=getVm("selection"),
col=getVm("col"), xlab=getLabel(vars[1]))
}
# barplot with missings
BarMiss <- function() {
vars <- union(getVm("vars"), getVm("highlight"))
x <- subset(get(ActiveDataSet(), envir=.GlobalEnv), select=vars)
dev.new()
barMiss(x, selection=getVm("selection"), col=getVm("col"), xlab=vars[1])
}
# barplot with imputed missings
BarImp <- function() {
vars <- union(getVm("vars"), getVm("highlight"))
vars <- c(vars,getVm("imp_vars"))
x <- subset(get(ActiveDataSet(), envir=.GlobalEnv), select=vars)
dev.new()
barMiss(x, delimiter=getVm("delimiter"), selection=getVm("selection"),
col=getVm("col"), xlab=vars[1])
}
# spine plot with missings
SpineplotMiss <- function() {
vars <- union(getVm("vars"), getVm("highlight"))
x <- subset(get(ActiveDataSet(), envir=.GlobalEnv), select=vars)
dev.new()
spineMiss(x, selection=getVm("selection"),
col=getVm("col"), xlab=vars[1])
}
# spine plot with imputed missings
SpineplotImp <- function() {
vars <- union(getVm("vars"), getVm("highlight"))
vars <- c(vars,getVm("imp_vars"))
x <- subset(get(ActiveDataSet(), envir=.GlobalEnv), select=vars)
dev.new()
spineMiss(x, delimiter=getVm("delimiter"), selection=getVm("selection"),
col=getVm("col"), xlab=vars[1])
}
# boxplot with missings
BoxMiss <- function() {
vars <- union(getVm("vars"), getVm("highlight"))
x <- subset(get(ActiveDataSet(), envir=.GlobalEnv), select=vars)
x[,1] <- prepare(x[,1], scaling=getVm("scaling"))
# if(length(vars) == 2) {
# boxnames <- paste(c("obs. in", "miss. in"), vars[2])
# } else boxnames <- rep("", 2)
t <- try(testMeans(x, selection=getVm("selection")), silent=TRUE)
if(class(t) != "try-error") {
d <- unlist(options("digits"))
cat(paste("\np.value: ", round(t$p.v, digits=d), "\n", sep=""))
}
dev.new()
# boxplot(x[!t$ind, 1], x[t$ind, 1], names=boxnames,
# col=getVm("col")[1:2], ylab=getLabel(vars[1]))
pbox(x, selection=getVm("selection"),
col=getVm("col")[c(1,2,4)], ylab=getLabel(vars[1]))
}
# boxplot with ipmuted missings
BoxImp <- function() {
vars <- union(getVm("vars"), getVm("highlight"))
vars <- c(vars,getVm("imp_vars"))
x <- subset(get(ActiveDataSet(), envir=.GlobalEnv), select=vars)
x[,1] <- prepare(x[,1], scaling=getVm("scaling"))
t <- try(testMeans(x, selection=getVm("selection")), silent=TRUE)
if(class(t) != "try-error") {
d <- unlist(options("digits"))
cat(paste("\np.value: ", round(t$p.v, digits=d), "\n", sep=""))
}
dev.new()
pbox(x, delimiter=getVm("delimiter"), selection=getVm("selection"),
col=getVm("col")[c(1,2,4,5,6)], ylab=getLabel(vars[1]))
}
# parallel boxplots
Pbox <- function() {
vars <- union(getVm("vars"), getVm("highlight"))
x <- subset(get(ActiveDataSet(), envir=.GlobalEnv), select=vars)
x[,1] <- prepare(x[,1], scaling=getVm("scaling"))
if(getVm("tkr")) {
TKRpbox(x, col=getVm("col")[c(1,2,4)], ylab=getLabel(vars[1]))
} else {
dev.new()
pbox(x, col=getVm("col")[c(1,2,4)], ylab=getLabel(vars[1]))
}
}
# parallel boxplots with imputed missings
PboxImp <- function() {
vars <- union(getVm("vars"), getVm("highlight"))
vars <- c(vars,getVm("imp_vars"))
x <- subset(get(ActiveDataSet(), envir=.GlobalEnv), select=vars)
x[,1] <- prepare(x[,1], scaling=getVm("scaling"))
if(getVm("tkr")) {
TKRpbox(x, delimiter=getVm("delimiter"),
col=getVm("col")[c(1,2,4,5,6)], ylab=getLabel(vars[1]))
} else {
dev.new()
pbox(x, delimiter=getVm("delimiter"),
col=getVm("col")[c(1,2,4,5,6)], ylab=getLabel(vars[1]))
}
}
# marginplot
Marginplot <- function() {
vars <- getVm("vars")
x <- subset(get(ActiveDataSet(), envir=.GlobalEnv), select=vars)
x <- prepare(x, scaling=getVm("scaling"))
labs <- getLabel(vars)
dev.new()
marginplot(x, col=getVm("col")[c(1,2,4)],
alpha=getVm("alpha"), xlab=labs[1], ylab=labs[2])
}
# marginplot with imputed missings
MarginplotImp <- function() {
vars <- c(getVm("vars"), getVm("imp_vars"))
x <- subset(get(ActiveDataSet(), envir=.GlobalEnv), select=vars)
x <- prepare(x, scaling=getVm("scaling"))
labs <- getLabel(vars)
dev.new()
marginplot(x, delimiter=getVm("delimiter"),
col=getVm("col")[c(1,2,4,5,6)], alpha=getVm("alpha"),
xlab=labs[1], ylab=labs[2])
}
# scatterplot with missings
ScattMiss <- function() {
vars <- getVm("vars")
x <- subset(get(ActiveDataSet(), envir=.GlobalEnv), select=vars)
x <- prepare(x, scaling=getVm("scaling"))
labs <- getLabel(vars)
dev.new()
scattMiss(x, col=getVm("col")[1:2],
alpha=getVm("alpha"), xlab=labs[1], ylab=labs[2])
}
# scatterplot with imputed missings
ScattImp <- function() {
vars <- c(getVm("vars"), getVm("imp_vars"))
x <- subset(get(ActiveDataSet(), envir=.GlobalEnv), select=vars)
x <- prepare(x, scaling=getVm("scaling"))
labs <- getLabel(vars)
dev.new()
scattMiss(x, delimiter=getVm("delimiter"), col=getVm("col")[c(1,2,5)],
alpha=getVm("alpha"), xlab=labs[1], ylab=labs[2])
}
# bivariate jitter plot
ScattJitt <- function() {
vars <- getVm("vars")
x <- subset(get(ActiveDataSet(), envir=.GlobalEnv), select=vars)
dev.new()
scattJitt(x, col=getVm("col")[c(1,2,4)], xlab=vars[1], ylab=vars[2])
}
# bivariate jitter plot with imputed missings
ScattJittImp <- function() {
vars <- c(getVm("vars"), getVm("imp_vars"))
x <- subset(get(ActiveDataSet(), envir=.GlobalEnv), select=vars)
dev.new()
scattJitt(x, delimiter=getVm("delimiter"),
col=getVm("col")[c(1,2,4,5,6)], xlab=vars[1], ylab=vars[2])
}
# marginplot matrix
Marginmatrix <- function() {
x <- subset(get(ActiveDataSet(), envir=.GlobalEnv),
select=getVm("vars"))
x <- prepare(x, scaling=getVm("scaling"))
if(getVm("tkr")) {
TKRmarginmatrix(x, col=getVm("col")[c(1,2,4)], alpha=getVm("alpha"))
} else {
dev.new()
marginmatrix(x, col=getVm("col")[c(1,2,4)], alpha=getVm("alpha"))
}
}
# marginplot matrix with imputed missings
MarginmatrixImp <- function() {
vars <- c(getVm("vars"), getVm("imp_vars"))
x <- subset(get(ActiveDataSet(), envir=.GlobalEnv),
select=vars)
x <- prepare(x, scaling=getVm("scaling"))
if(getVm("tkr")) {
TKRmarginmatrix(x, delimiter=getVm("delimiter"),
col=getVm("col")[c(1,2,4,5,6)], alpha=getVm("alpha"))
} else {
dev.new()
marginmatrix(x, delimiter=getVm("delimiter"),
col=getVm("col")[c(1,2,4,5,6)], alpha=getVm("alpha"))
}
}
# scatterplot matrix with missings
ScattmatrixMiss <- function() {
vars <- getVm("vars")
highlight <- getVm("highlight")
x <- subset(get(ActiveDataSet(), envir=.GlobalEnv),
select=union(vars, highlight))
x[,vars] <- prepare(x[,vars], scaling=getVm("scaling"))
if(getVm("tkr")) {
TKRscattmatrixMiss(x, highlight=highlight,
selection=getVm("selection"),
plotvars=vars, col=getVm("col")[1:2],
alpha=getVm("alpha"))
} else {
dev.new()
scattmatrixMiss(x, highlight=highlight,
selection=getVm("selection"),
plotvars=vars, col=getVm("col")[1:2],
alpha=getVm("alpha"))
}
}
# scatterplot matrix with imputed missings
ScattmatrixImp <- function() {
vars <- getVm("vars")
highlight <- getVm("highlight")
x <- subset(get(ActiveDataSet(), envir=.GlobalEnv),
select=c(union(vars, highlight), getVm("imp_vars")))
x[,vars] <- prepare(x[,vars], scaling=getVm("scaling"))
if(getVm("tkr")) {
TKRscattmatrixMiss(x, delimiter=getVm("delimiter"),
highlight=highlight, selection=getVm("selection"),
plotvars=vars, col=getVm("col")[c(1,2,5)],
alpha=getVm("alpha"))
} else {
dev.new()
scattmatrixMiss(x, delimiter=getVm("delimiter"),
highlight=highlight, selection=getVm("selection"),
plotvars=vars, col=getVm("col")[c(1,2,5)],
alpha=getVm("alpha"))
}
}
# parallel coordinate plot with missings
ParcoordMiss <- function() {
vars <- getVm("vars")
highlight <- getVm("highlight")
x <- subset(get(ActiveDataSet(), envir=.GlobalEnv),
select=union(vars, highlight))
x[,vars] <- prepare(x[,vars], scaling=getVm("scaling"))
if(getVm("tkr")) {
TKRparcoordMiss(x, highlight=highlight,
selection=getVm("selection"), plotvars=vars, col=getVm("col"),
alpha=getVm("alpha"))
}else {
dev.new()
parcoordMiss(x, highlight=highlight, selection=getVm("selection"),
plotvars=vars, col=getVm("col"), alpha=getVm("alpha"))
}
}
# parallel coordinate plot with imputed missings
ParcoordImp <- function() {
vars <- getVm("vars")
highlight <- getVm("highlight")
x <- subset(get(ActiveDataSet(), envir=.GlobalEnv),
select=c(union(vars, highlight), getVm("imp_vars")))
x[,vars] <- prepare(x[,vars], scaling=getVm("scaling"))
if(getVm("tkr")) {
TKRparcoordMiss(x, delimiter=getVm("delimiter"), highlight=highlight,
selection=getVm("selection"), plotvars=vars, col=getVm("col"),
alpha=getVm("alpha"))
}else {
dev.new()
parcoordMiss(x, delimiter=getVm("delimiter"), highlight=highlight, selection=getVm("selection"),
plotvars=vars, col=getVm("col"), alpha=getVm("alpha"))
}
}
# matrix plot
Matrixplot <- function() {
x <- subset(get(ActiveDataSet(), envir=.GlobalEnv),
select=getVm("vars"))
x <- prepare(x, scaling=getVm("scaling"))
if(getVm("tkr")) TKRmatrixplot(x, col=getVm("col")[2])
else {
dev.new()
matrixplot(x, col=getVm("col")[2])
}
}
# matrix plot with imputed missings
MatrixplotImp <- function() {
vars <- c(getVm("vars"), getVm("imp_vars"))
x <- subset(get(ActiveDataSet(), envir=.GlobalEnv),
select=vars)
x <- prepare(x, scaling=getVm("scaling"))
if(getVm("tkr")) TKRmatrixplot(x, delimiter=getVm("delimiter"), col=getVm("col")[c(2,5)])
else {
dev.new()
matrixplot(x, delimiter=getVm("delimiter"), col=getVm("col")[c(2,5)])
}
}
# mosaic plot
MosaicMiss <- function() {
vars <- getVm("vars")
highlight <- getVm("highlight")
x <- subset(get(ActiveDataSet(), envir=.GlobalEnv),
select=union(vars, highlight))
dev.new()
mosaicMiss(x, highlight=highlight, selection=getVm("selection"),
plotvars=vars, col=getVm("col")[1:2], miss.labels=FALSE)
}
# mosaic plot with imputed Missings
MosaicImp <- function() {
vars <- getVm("vars")
highlight <- getVm("highlight")
x <- subset(get(ActiveDataSet(), envir=.GlobalEnv),
select=c(union(vars, highlight), getVm("imp_vars")))
dev.new()
mosaicMiss(x, delimiter=getVm("delimiter"), highlight=highlight,
selection=getVm("selection"), plotvars=vars,
col=getVm("col")[c(1,2,5)], miss.labels=FALSE)
}
# map of missings
MapMiss <- function() {
activeData <- get(ActiveDataSet(), envir=.GlobalEnv)
x <- subset(activeData, select=getVm("vars"))
coords <- subset(activeData, select=getVm("coords"))
# main <- paste("Selected variables:\n", paste(colnames(x),
# collapse=", "))
dev.new()
mapMiss(x, coords, map=getVm("map"), selection=getVm("selection"),
col=getVm("col")[1:2], alpha=getVm("alpha"), legend=TRUE,
cex.main=1)
}
# map of imputed missings
MapImp <- function() {
vars <- c(getVm("vars"), getVm("imp_vars"))
activeData <- get(ActiveDataSet(), envir=.GlobalEnv)
x <- subset(activeData, select=vars)
coords <- subset(activeData, select=getVm("coords"))
# main <- paste("Selected variables:\n", paste(colnames(x),
# collapse=", "))
dev.new()
mapMiss(x, coords, map=getVm("map"), delimiter=getVm("delimiter"),
selection=getVm("selection"), col=getVm("col")[c(1,2,5)],
alpha=getVm("alpha"), legend=TRUE, cex.main=1)
}
# growing dot map with missings
GrowdotMiss <- function() {
activeData <- get(ActiveDataSet(), envir=.GlobalEnv)
x <- subset(activeData, select=union(getVm("vars"), getVm("highlight")))
x[,1] <- prepare(x[,1], scaling=getVm("scaling"))
coords <- subset(activeData, select=getVm("coords"))
alpha <- getVm("alpha")
border <- if(alpha == 1) "white" else "transparent"
dev.new()
growdotMiss(x, coords, map=getVm("map"), selection=getVm("selection"),
col=getVm("col"), alpha=alpha, border=border, legend=TRUE)
}
# growing dot map with imputed missings
GrowdotImp <- function() {
vars <- c(getVm("vars"), getVm("imp_vars"))
activeData <- get(ActiveDataSet(), envir=.GlobalEnv)
x <- subset(activeData, select=union(vars, getVm("highlight")))
x[,1] <- prepare(x[,1], scaling=getVm("scaling"))
coords <- subset(activeData, select=getVm("coords"))
alpha <- getVm("alpha")
border <- if(alpha == 1) "white" else "transparent"
dev.new()
growdotMiss(x, coords, map=getVm("map"), delimiter=getVm("delimiter"),
selection=getVm("selection"), col=getVm("col"), alpha=alpha,
border=border, legend=TRUE)
}
# map with colored regions
ColormapMiss <- function() {
activeData <- get(ActiveDataSet(), envir=.GlobalEnv)
x <- activeData[, getVm("vars")]
region <- activeData[, getVm("region")]
dev.new()
colormapMiss(x, region, map=getVm("map"), col=getVm("col")[2])
}
# map with colored regions
ColormapImp <- function() {
activeData <- get(ActiveDataSet(), envir=.GlobalEnv)
var <- getVm("vars")
x <- activeData[, var]
region <- activeData[, getVm("region")]
# get imputation-index for the variable (if exists)
delimiter <- getVm("delimiter")
imp_var <- grep(delimiter, colnames(activeData), value = TRUE)
imp_var <- imp_var[imp_var %in% paste(var,delimiter, sep="")]
if(length(imp_var) != 0) imp_var <- activeData[, imp_var]
else imp_var <- NULL
dev.new()
colormapMiss(x, region, map=getVm("map"), imp_index = imp_var,
col=getVm("col")[c(2,5)])
}
## functions bound to options menu
# preferences (colors and alpha value)
vmGUIpreferences <- function() {
# start dialog
ttP <- initializeDialog("Preferences")
# combo boxes for plot colors
colFrame <- tkwidget(ttP, "labelframe",
text="Select Plot Colors", fg="blue")
colsFrame <- tkframe(colFrame)
col <- getVm("col")
col1Variable <- tclVar(col[1])
col2Variable <- tclVar(col[2])
col3Variable <- tclVar(col[3])
col4Variable <- tclVar(col[4])
col5Variable <- tclVar(col[5])
col6Variable <- tclVar(col[6])
setCol <- function() tkfocus(ttP)
col1ComboBox <- tkwidget(colsFrame, "ComboBox", "-modifycmd", setCol,
values=colors(), width=12, textvariable=col1Variable)
col2ComboBox <- tkwidget(colsFrame, "ComboBox", "-modifycmd", setCol,
values=colors(), width=12, textvariable=col2Variable)
col3ComboBox <- tkwidget(colsFrame, "ComboBox", "-modifycmd", setCol,
values=colors(), width=12, textvariable=col3Variable)
col4ComboBox <- tkwidget(colsFrame, "ComboBox", "-modifycmd", setCol,
values=colors(), width=12, textvariable=col4Variable)
col5ComboBox <- tkwidget(colsFrame, "ComboBox", "-modifycmd", setCol,
values=colors(), width=12, textvariable=col5Variable)
col6ComboBox <- tkwidget(colsFrame, "ComboBox", "-modifycmd", setCol,
values=colors(), width=12, textvariable=col6Variable)
tkgrid(tklabel(colsFrame,text="Color 1: "), col1ComboBox)
tkgrid(tklabel(colsFrame,text="Color 2: "), col2ComboBox)
tkgrid(tklabel(colsFrame,text="Color 3: "), col3ComboBox)
tkgrid(tklabel(colsFrame,text="Color 4: "), col4ComboBox)
tkgrid(tklabel(colsFrame,text="Color 5: "), col5ComboBox)
tkgrid(tklabel(colsFrame,text="Color 6: "), col6ComboBox)
tkgrid(colsFrame, padx=3, pady=3)
# scale for alpha value
alphaFrame <- tkwidget(ttP, "labelframe",
text="Set Alpha Value", fg="blue")
alphaVariable <- tclVar(getVm("alpha"))
alphaScale <- tkscale(alphaFrame, orient="horizontal", from=0, to=1,
resolution=1/255, length=256, variable=alphaVariable)
tkgrid(alphaScale, padx=3, pady=3)
# misc
miscFrame <- tkwidget(ttP, "labelframe",
text="Miscellaneous", fg="blue")
tkrBox <- checkboxes(miscFrame, boxes="tkr", initial=getVm("tkr"),
labels="Embed multivariate plots in Tcl/Tk")
tkgrid(tkrBox$frame, padx=3, pady=3)
# Delimiter for imputed Variables
delimiterFrame <- tkwidget(ttP, "labelframe",
text = "Set imputation-delimiter", fg="blue")
delimiter <- getVm("delimiter")
delimiterEntry <- tkwidget(delimiterFrame, "Entry", width=12, text=delimiter, textvariable=delimiter)
tkgrid(delimiterEntry, padx=3, pady=3)
# onOK function
onOK <- function() {
col <- c(tclvalue(col1Variable), tclvalue(col2Variable),
tclvalue(col3Variable), tclvalue(col4Variable), tclvalue(col5Variable),
tclvalue(col6Variable))
alpha <- as.numeric(tclvalue(alphaVariable))
tkr <- getSelection(tkrBox)
delimiter <- tclvalue(delimiter)
putVm("col", col)
putVm("alpha", alpha)
putVm("tkr", tkr)
putVm("delimiter", delimiter)
# activateMenus()
closeDialog(ttP, parent=ttM)
}
# ok and cancel buttons
buttons <- okCancel(ttP, onOK, parent=ttM)
# display dialog elements
tkgrid(colFrame, padx=10, pady=5, sticky="news")
tkgrid(alphaFrame, padx=10, pady=5, sticky="news")
tkgrid(miscFrame, padx=10, pady=5, sticky="news")
tkgrid(delimiterFrame, padx=10, pady=5, sticky="news")
tkgrid(buttons$frame)
}
## initialize dialog and add menu
ttM <- initializeDialog("Visualization and Imputation of Missing Values")
tkwm.protocol(ttM, "WM_DELETE_WINDOW", Quit)
putVm(".ttM", ttM)
topMenu <- tkmenu(ttM)
tkconfigure(ttM, menu=topMenu)
DataMenu <- tkmenu(topMenu, tearoff=FALSE)
VisualizationMenu <- tkmenu(topMenu, tearoff=FALSE)
ImputationMenu <- tkmenu(topMenu, tearoff=FALSE)
OptionsMenu <- tkmenu(topMenu, tearoff=FALSE)
DiagnosticsMenu <- tkmenu(topMenu, tearoff=FALSE)
# TO DO:
# ----------
#SimulationMenu <- tkmenu(topMenu, tearoff=FALSE)
# ----------
tkadd(topMenu, "cascade", label="Data", menu=DataMenu)
tkadd(topMenu, "cascade", label="Visualization", menu=VisualizationMenu)
# use following commands until other menus are implemented
tkadd(topMenu, "cascade", label="Imputation", menu=ImputationMenu)
#tkadd(topMenu, "command", label="Diagnostics", command=NotImplemented)
tkadd(topMenu, "cascade", label="Diagnostics", menu=DiagnosticsMenu)
#tkadd(topMenu, "command", label="Simulation", command=NotImplemented)
# ----------
tkadd(topMenu, "cascade", label="Options", menu=OptionsMenu)
tkadd(topMenu, "command", label="Quit", command=Quit)
#DataMenu
tkadd(DataMenu, "command", label="Select Data", command=vmGUIdata)
tkadd(DataMenu, "command", label="Load R Data", command=LoadRData)
tkadd(DataMenu, "command", label="Transform Variables",
command=vmGUItransform)
tkadd(DataMenu, "command", label="Background Map", command=vmGUImap)
########################################################################
#VisualizationMenu
tkadd(VisualizationMenu, "command",
label="Aggregate Missings", command=Aggr)
tkadd(VisualizationMenu, "command",
label="Histogram with Missings", command=HistMiss)
tkadd(VisualizationMenu, "command",
label="Spinogram with Missings", command=SpinogramMiss)
tkadd(VisualizationMenu, "command",
label="Barplot with Missings", command=BarMiss)
tkadd(VisualizationMenu, "command",
label="Spine Plot with Missings", command=SpineplotMiss)
tkadd(VisualizationMenu, "command",
label="Boxplot with Missings", command=BoxMiss)
tkadd(VisualizationMenu, "command",
label="Parallel Boxplots", command=Pbox)
tkadd(VisualizationMenu, "command",
label="Marginplot", command=Marginplot)
tkadd(VisualizationMenu, "command",
label="Scatterplot with Missings", command=ScattMiss)
tkadd(VisualizationMenu, "command",
label="Bivariate Jitter Plot", command=ScattJitt)
tkadd(VisualizationMenu, "command",
label="Marginplot Matrix",
command=Marginmatrix)
tkadd(VisualizationMenu, "command",
label="Scatterplot Matrix with Missings",
command=ScattmatrixMiss)
tkadd(VisualizationMenu, "command",
label="Parallel Coordinate Plot with Missings",
command=ParcoordMiss)
tkadd(VisualizationMenu, "command",
label="Matrix Plot", command=Matrixplot)
tkadd(VisualizationMenu, "command",
label="Mosaic Plot with Missings", command=MosaicMiss)
tkadd(VisualizationMenu, "command",
label="Map of Missings", command=MapMiss)
tkadd(VisualizationMenu, "command",
label="Growing Dot Map with Missings", command=GrowdotMiss)
tkadd(VisualizationMenu, "command",
label="Map with Colored Regions", command=ColormapMiss)
########################################################################
#ImputationMenu
tkadd(ImputationMenu, "command",
label="k Nearest Neighbour", command=knnGUI)
tkadd(ImputationMenu, "command",
label="Hot Deck", command=hotdeckGUI)
tkadd(ImputationMenu, "command",
label="IRMI", command=irmiGUI)
########################################################################
#DiagnosticsMenu
tkadd(DiagnosticsMenu, "command",
label="Aggregate Missings and imputed Missings", command=AggrImp)
tkadd(DiagnosticsMenu, "command",
label="Histogram with imputed Missings", command=HistImp)
tkadd(DiagnosticsMenu, "command",
label="Spinogram with imputed Missings", command=SpinogramImp)
tkadd(DiagnosticsMenu, "command",
label="Barplot with imputed Missings", command=BarImp)
tkadd(DiagnosticsMenu, "command",
label="Spine Plot with imputed Missings", command=SpineplotImp)
tkadd(DiagnosticsMenu, "command",
label="Boxplot with imputed Missings", command=BoxImp)
tkadd(DiagnosticsMenu, "command",
label="Parallel Boxplots", command=PboxImp)
tkadd(DiagnosticsMenu, "command",
label="Marginplot", command=MarginplotImp)
tkadd(DiagnosticsMenu, "command",
label="Scatterplot with imputed Missings", command=ScattImp)
tkadd(DiagnosticsMenu, "command",
label="Bivariate Jitter Plot", command=ScattJittImp)
tkadd(DiagnosticsMenu, "command",
label="Marginplot Matrix",
command=MarginmatrixImp)
tkadd(DiagnosticsMenu, "command",
label="Scatterplot Matrix with imputed Missings",
command=ScattmatrixImp)
tkadd(DiagnosticsMenu, "command",
label="Parallel Coordinate Plot with imputed Missings",
command=ParcoordImp)
tkadd(DiagnosticsMenu, "command",
label="Matrix Plot", command=MatrixplotImp)
tkadd(DiagnosticsMenu, "command",
label="Mosaic Plot with imputed Missings", command=MosaicImp)
tkadd(DiagnosticsMenu, "command",
label="Map of imputed Missings", command=MapImp)
tkadd(DiagnosticsMenu, "command",
label="Growing Dot Map with imputed Missings", command=GrowdotImp)
tkadd(DiagnosticsMenu, "command",
label="Map with Colored Regions", command=ColormapImp)
########################################################################
#OptionsMenu
tkadd(OptionsMenu, "command", label="Preferences", command=vmGUIpreferences)
activateMenus()
## frames
varsFrame <- tkwidget(ttM, "labelframe",
text="Select Variables", fg="blue")
highlightFrame <- tkwidget(ttM, "labelframe",
text="Highlight Variables in Plots", fg="blue")
scalingFrame <- tkwidget(ttM, "labelframe",
text="Scaling", fg="blue")
selectionFrame <- tkwidget(ttM, "labelframe",
text="Selection for Highlighting", fg="blue")
## dialog elements
# listbox for plot variables
varsBox <- listbox(varsFrame, initial=vars,
height=6, selectmode="extended")
#putVm(".varsBox", varsBox)
# select and deselect all variables radiobuttons
varsButtons <- radiobuttons(varsFrame,
buttons=c("varsSelectAll","varsDeselectAll"),
labels=c("Select all","Deselect all"))
# scaling
scalingButtons <- radiobuttons(scalingFrame,
buttons=c("none","classical","MCD","robust"),
labels=c("None","Classical",
"Robust (MCD)","Robust (median, MAD)"),
initial=scaling)
# listbox for highlight variables
highlightBox <- listbox(highlightFrame,
initial=highlight, height=6, selectmode="extended")
# select and deselect all variables radiobuttons
highlightButtons <- radiobuttons(highlightFrame,
buttons=c("highlightSelectAll","highlightDeselectAll"),
labels=c("Select all","Deselect all"))
# selection method for highlight variables
selectionButtons <- radiobuttons(selectionFrame, buttons=c("any","all"),
labels=c("any","all"), initial=selection)
## functions bound to dialog elements
# variables
setVars <- function() {
oldVars <- getVm("vars")
selVars <- getSelection(varsBox)
newVars <- setdiff(selVars, oldVars)
vars <- c(intersect(oldVars, selVars), newVars)
putVm("vars", vars)
deselectAll(varsButtons)
activateMenus()
activateElements()
}
varsSelectAll <- function() {
oldVars <- getVm("vars")
allVars <- getVars()
newVars <- setdiff(allVars, oldVars)
vars <- c(oldVars, newVars)
putVm("vars", vars)
selectAll(varsBox)
activateMenus()
activateElements()
}
varsDeselectAll <- function() {
vars <- character()
putVm("vars", vars)
deselectAll(varsBox)
activateMenus()
activateElements()
}
# scaling
setScaling <- function() {
scaling <- getSelection(scalingButtons)
putVm("scaling", scaling)
}
# highlight variables
setHighlight <- function() {
oldHighlight <- getVm("highlight")
selHighlight <- getSelection(highlightBox)
newHighlight <- setdiff(selHighlight, oldHighlight)
highlight <- c(intersect(oldHighlight, selHighlight), newHighlight)
putVm("highlight", highlight)
deselectAll(highlightButtons)
activateMenus()
activateElements()
}
highlightSelectAll <- function() {
oldHighlight <- getVm("highlight")
allVars <- getVars()
newHighlight <- setdiff(allVars, oldHighlight)
highlight <- c(oldHighlight, newHighlight)
putVm("highlight", highlight)
selectAll(highlightBox)
activateMenus()
activateElements()
}
highlightDeselectAll <- function() {
highlight <- character()
putVm("highlight", highlight)
deselectAll(highlightBox)
activateMenus()
activateElements()
}
# selection method for highlight variables
setSelection <- function() {
selection <- getSelection(selectionButtons)
putVm("selection", selection)
}
## function to set states of dialog elements
activateElements <- function() {
boxesS <- checkActiveDataS() # state for listboxes
# variables
setState(varsBox, boxesS)
bind(varsBox, setVars)
setState(varsButtons, boxesS)
bind(varsButtons, varsSelectAll, "varsSelectAll")
bind(varsButtons, varsDeselectAll, "varsDeselectAll")
# scaling
setState(scalingButtons, checkVarsS())
bind(scalingButtons, setScaling)
# highlight variables
setState(highlightBox, boxesS)
bind(highlightBox, setHighlight)
setState(highlightButtons, boxesS)
bind(highlightButtons, highlightSelectAll, "highlightSelectAll")
bind(highlightButtons, highlightDeselectAll, "highlightDeselectAll")
# selection method for highlight variables
setState(selectionButtons, getSelectionS())
bind(selectionButtons, setSelection)
}
## display dialog elements
activateElements()
tkpack(varsBox$frame, varsButtons$frame,
expand=TRUE, fill="x", padx=3, pady=3, side="left")
tkpack(scalingButtons$frame, expand=TRUE,
fill="x", padx=3, pady=3, side="left")
tkgrid(varsFrame, scalingFrame, padx=10, pady=5, sticky="news")
tkpack(highlightBox$frame, highlightButtons$frame,
expand=TRUE, fill="x", padx=3, pady=3, side="left")
tkpack(selectionButtons$frame, expand=TRUE,
fill="x", padx=3, pady=3, side="left")
tkgrid(highlightFrame, selectionFrame, padx=10, pady=5, sticky="news")
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.