.packageName <- "Rcmdr"
# this code by Dan Putler, used with permission

assignCluster <- function(clusterData, origData, clusterVec){
    rowsDX <- row.names(clusterData)
    rowsX <- row.names(origData)
    clustAssign <- rep(NA, length(rowsX))
    validData <- rowsX %in% rowsDX
    clustAssign[validData] <- clusterVec
    return(as.factor(clustAssign))
    }

KMeans <- function (x, centers, iter.max=10, num.seeds=10) {
    KM <- kmeans(x=x, centers=centers, iter.max=iter.max)
    for(i in 2:num.seeds) {
        newKM <- kmeans(x=x, centers=centers, iter.max=iter.max)
        if(sum(newKM$withinss) < sum(KM$withinss)) {
            KM <- newKM
            }
        }
    KM$tot.withinss <- sum(KM$withinss)
    xmean <- apply(x, 2, mean)
    centers <- rbind(KM$centers, xmean)
    bss1 <- as.matrix(dist(centers)^2)
    KM$betweenss <- sum(as.vector(bss1[nrow(bss1),])*c(KM$size,0))
    return(KM)
    }

listKmeansSolutions <- function(envir=.GlobalEnv, ...) {
    objects <- ls(envir=envir, ...)
    if (length(objects) == 0) NULL
    else objects[sapply(objects, 
        function(.x) {
            if(mode(eval(parse(text=.x), envir=envir)) != "list" )
                return(FALSE)
            else {"cluster" == (names(eval(parse(text=.x),
                envir=envir))[1]) &
              "centers" == (names(eval(parse(text=.x), envir=envir))[2])}
            }
         )]
    }

kmeansClustering <- function(){
    if(!checkActiveDataSet()) return()
    if(!checkNumeric()) return()
    initializeDialog(title="KMeans Clustering")
    dataFrame <- tkframe(top)
    xBox <- variableListBox(dataFrame, .numeric, selectmode="multiple",
      title="Variables (pick one or more)")
    subsetBox(dataFrame)
    optionsFrame <- tkframe(top)
    clusterNumber <- tclVar("2")
    clusterNumSlider <- tkscale(optionsFrame, from=2, to=10, showvalue=TRUE,
      variable=clusterNumber, resolution=1, orient="horizontal")
    seedNumber <- tclVar("10")
    seedNumSlider <- tkscale(optionsFrame, from=1, to=20, showvalue=TRUE,
      variable=seedNumber, resolution=1, orient="horizontal")
    iterNumber <- tclVar("10")
    iterNumSlider <- tkscale(optionsFrame, from=5, to=30, showvalue=TRUE,
      variable=iterNumber, resolution=5, orient="horizontal")
    summaryClusters <- tclVar("1")
    summaryCB <- tkcheckbutton(optionsFrame)
    tkconfigure(summaryCB, variable=summaryClusters)
    plotClusters <- tclVar("1")
    plotCB <- tkcheckbutton(optionsFrame)
    tkconfigure(plotCB, variable=plotClusters)
    assignClusters <- tclVar("0")
    assignCB <- tkcheckbutton(optionsFrame)
    tkconfigure(assignCB, variable=assignClusters)
    assignName <- tclVar("KMeans")
    assignField <- tkentry(optionsFrame, width="15",
      textvariable=assignName)
    onOK <- function(){
        x <- getSelection(xBox)
        nvar <- length(x)
        subset <- trim.blanks(tclvalue(subsetVariable))
        nClusters <- tclvalue(clusterNumber)
        seeds <- tclvalue(seedNumber)
        iters <- tclvalue(iterNumber)
        clusterSummary <- tclvalue(summaryClusters)
        clusterPlot <- tclvalue(plotClusters)
        clusterAssign <- tclvalue(assignClusters)
        clusterVariable <- trim.blanks(tclvalue(assignName))
        if (clusterAssign == "1"){
           if (is.element(clusterVariable, .variables)) {
                if ("no" == tclvalue(checkReplace(clusterVariable))){
                    if (.grab.focus) tkgrab.release(top)
                    tkdestroy(top)
                    kmeansClustering()
                    return()
                    }
                }
           } 
        if (length(x)==0) {
            errorCondition(recall=kmeansClustering, 
              message="No variables selected.")
            return()
            }
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        varFormula <- paste(x, collapse=" + ")
        vars <- paste(x, collapse=",", sep="")
        dset <- if (trim.blanks(subset) == "<all valid cases>") .activeDataSet
          else {paste(.activeDataSet, "[", .activeDataSet, "$", subset, ", ]",
            sep="")}
        xmat <- paste("model.matrix(~-1 + ", varFormula, ", ", dset, ")",
          sep="")
        command <- paste("KMeans(", xmat, ", centers = ", nClusters,
          ", iter.max = ", iters, ", num.seeds = ", seeds, ")", sep="")
        assign(".cluster", justDoIt(command), envir=.GlobalEnv)
        logger(paste(".cluster <- ", command, sep=""))
        if (clusterSummary == "1") {
            doItAndPrint(paste(".cluster$size # Cluster Sizes"))
            doItAndPrint(paste(".cluster$centers # Cluster Centroids"))
            doItAndPrint(paste(
              ".cluster$withinss # Within Cluster Sum of Squares"))
            doItAndPrint(paste(
              ".cluster$tot.withinss # Total Within Sum of Squares"))
            doItAndPrint(paste(
              ".cluster$betweenss # Between Cluster Sum of Squares"))
            }
        if (clusterPlot == "1") {
            plotCommand <- paste("biplot(princomp(", xmat, 
              "), xlabs = as.character(.cluster$cluster))", sep="")
           justDoIt(plotCommand)
           logger(plotCommand)
           }
        if (clusterAssign == "1") {
            assignCommand <- paste(.activeDataSet, "$", clusterVariable,
              " <- assignCluster(", xmat, ", ", .activeDataSet,
              ", .cluster$cluster)", sep="")
            justDoIt(assignCommand)
            logger(assignCommand)
            activeDataSet(.activeDataSet)
            }
        justDoIt(paste("remove(.cluster)"))
        logger(paste("remove(.cluster)"))
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="KMeans")
    tkgrid(getFrame(xBox), sticky="nw")
    tkgrid(subsetFrame, sticky="w")
    tkgrid(tklabel(optionsFrame, text="Number of clusters:"),
      clusterNumSlider, sticky="sw")
    tkgrid(tklabel(optionsFrame, text="Number of starting seeds:"),
      seedNumSlider, sticky="sw")
    tkgrid(tklabel(optionsFrame, text="Maximum iterations:"),
      iterNumSlider, sticky="sw")
    tkgrid(tklabel(optionsFrame, 
      text="Print cluster summary"), summaryCB, sticky="w")
    tkgrid(tklabel(optionsFrame, 
      text="Bi-plot of clusters"), plotCB, sticky="w")
    tkgrid(tklabel(optionsFrame, 
      text="Assign clusters to\nthe data set         "),
      assignCB, sticky="w")
    tkgrid(tklabel(optionsFrame, text="Assignment variable: "),
      assignField, sticky="w")
    tkgrid(dataFrame, tklabel(top, text="  "), optionsFrame,
        sticky="nw")
    tkgrid(buttonsFrame, columnspan=3, sticky="w")
    dialogSuffix(rows=3, columns=3)
    }

listHclustSolutions <- function(envir=.GlobalEnv, ...) {
    objects <- ls(envir=envir, ...)
    if (length(objects) == 0) NULL
    else objects[sapply(objects, 
        function(.x) "hclust" == (class(eval(parse(text=.x), envir=envir))[1]))]
    }

hierarchicalCluster <- function(){
    if(!checkActiveDataSet()) return()
    if(!checkNumeric()) return()
    solutionNumber=length(listHclustSolutions())
    initializeDialog(title="Hierarchical Clustering")
    solutionFrame <- tkframe(top)
    solutionName <- tclVar(paste("HClust.", (solutionNumber+1),
        sep=""))
    solutionField <- tkentry(solutionFrame, width="20",
      textvariable=solutionName)
    dataFrame <- tkframe(top)
    xBox <- variableListBox(dataFrame, .numeric, selectmode="multiple",
      title="Variables (pick one or more)")
    subsetBox(dataFrame)
    radioButtons(name="method",
      buttons=c("ward", "single", "complete","average", "mcquitty", "median",
      "centroid"), labels=c("Ward's Method", "Single Linkage",
      "Complete Linkage", "Average Linkage", "McQuitty's Method",
      "Median Linkage", "Centroid Linkage"), title="Clustering Method")
    optionsFrame <- tkframe(top)
    radioButtons(optionsFrame, name="distanceType", buttons=c("euc", "euc2",
      "city", "none"), labels=c("Euclidean", "Squared-Euclidian", 
      "Manhattan (City Block)", "No Transformation"), title="Distance Measure")
    checkFrame <- tkframe(optionsFrame)
    plotDendro <- tclVar("1")
    plotCB <- tkcheckbutton(checkFrame)
    tkconfigure(plotCB, variable=plotDendro)
    onOK <- function(){
        x <- getSelection(xBox)
        nvar <- length(x)
        clusMethod <- tclvalue(methodVariable)
        distance <- tclvalue(distanceTypeVariable)
        subset <- trim.blanks(tclvalue(subsetVariable))
        dendro <- tclvalue(plotDendro)
        solution <- trim.blanks(tclvalue(solutionName))
        if (length(x)==0) {
            errorCondition(recall=hierarchicalCluster, 
              message="No variables selected.")
            return()
            }
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        varFormula <- paste(x, collapse="+")
        vars <- paste(x, collapse=",", sep="")
        dset <- if (subset == "<all valid cases>") .activeDataSet
          else {paste(.activeDataSet, "[", .activeDataSet, "$", subset, ", ]",
            sep="")}
        xmat <- paste("model.matrix(~-1 + ", varFormula, ", ", dset, ")",
          sep="")
        if(distance=="euc") {
            dx <- paste("dist(", xmat, ")", sep="")
            distlab <- "euclidian"
        }
        else if(distance=="euc2") {
            dx <- paste("dist(", xmat, ")^2", sep="")
            distlab <- "squared-euclidian"
        }
        else if(distance=="city") {
            dx <- paste("dist(", xmat, ", method= ", '"manhattan"', ")",
                sep="")
            distlab <- "city-block"
        }
        else {
            dx <- xmat
            distlab <- "untransformed"
        }
        command <- paste("hclust(", dx, " , method= ", '"', clusMethod, '"',
          ")", sep="")
        assign(solution, justDoIt(command), envir=.GlobalEnv)
        logger(paste(solution, " <- ", command, sep=""))
        if (dendro == "1") {
            justDoIt(paste("plot(", solution, ", main= ",'"',
              "Cluster Dendrogram for Solution ", solution, '"', ", xlab= ",
              '"',"Observation Number in Data Set ", dset, '"',
               ", sub=", '"', "Method=", clusMethod,
              "; Distance=", distlab, '"', ")", sep=""))
            logger(paste("plot(", solution, ", main= ",'"',
              "Cluster Dendrogram for Solution ", solution, '"', ", xlab= ",
              '"',"Observation Number in Data Set ", dset, '"',
               ", sub=", '"', "Method=", clusMethod,
              "; Distance=", distlab, '"', ")",
              sep=""))
            }
         tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="hclust")
    tkgrid(solutionField, sticky="w")
    tkgrid(tklabel(top, text="Clustering solution name:"),
      solutionFrame, sticky="w")
    tkgrid(getFrame(xBox), sticky="nw")
    tkgrid(subsetFrame, sticky="w")
    tkgrid(distanceTypeFrame, sticky="w")
    tkgrid(tklabel(checkFrame, text="  "), sticky="w")
    tkgrid(tklabel(checkFrame, text="Plot Dendrogram  "), plotCB,
      sticky="w")
    tkgrid(checkFrame, sticky="w")
    tkgrid(dataFrame, methodFrame, optionsFrame, sticky="nw")
    tkgrid(buttonsFrame, columnspan=3, sticky="w")
    dialogSuffix(rows=3, columns=3)
    }

hclustSummary <- function(){
    if(!checkActiveDataSet()) return()
    parseDataSet <- function(x) {
        y <- eval(parse(text=paste(x, "$call", sep="")))
        string1 <- unlist(strsplit(as.character(y)[2], "\\("))
        string2 <- unlist(strsplit(string1[3], ","))
        if(length(grep("\\[", string2[2])) == 0) {
            out <- gsub(")", "", gsub(" ", "", gsub("\\^2", "",
                string2[2])))
            }
        else {
            string3 <- unlist(strsplit(string2[2], "\\["))
            out <- gsub(" ", "", string3[1])
            }
        return(out)
        }
    hclustObjects <- listHclustSolutions()
    testDataSet <- tapply(hclustObjects, as.factor(1:length(hclustObjects)),
      parseDataSet)
    validHclust <- hclustObjects[testDataSet==.activeDataSet]
    initializeDialog(
      title="Hierarchical Cluster Summary")
    hclustBox <- variableListBox(top, validHclust, selectmode="single",
      title="Select One Clustering Solution")
    optionsFrame <- tkframe(top)
    clusterNumber <- tclVar("2")
    slider <- tkscale(optionsFrame, from=2, to=10, showvalue=TRUE,
      variable=clusterNumber, resolution=1, orient="horizontal")
    summaryClusters <- tclVar("1")
    summaryCB <- tkcheckbutton(optionsFrame)
    tkconfigure(summaryCB, variable=summaryClusters)
    plotClusters <- tclVar("1")
    plotCB <- tkcheckbutton(optionsFrame)
    tkconfigure(plotCB, variable=plotClusters)
    if(length(hclustObjects)==0) {
        errorCondition(recall=return,
          message="There are no hierachical clustering solutions")
        }
    if(length(validHclust)==0) {
        errorCondition(recall=return, message=
     "No hierachical clustering solutions are associated with this data set.")
        }
   onOK <- function(){
        solution <- getSelection(hclustBox)
        if(length(solution)==0) {
          errorCondition(recall=appendHclustGroup,
            message="A clustering solution has not been selected.")
          return()
            }
        clusters <- as.numeric(tclvalue(clusterNumber))
        clusterVar <- paste("cutree(", solution, ", k = ", clusters, ")",
          sep="")
        clusterSummary <- tclvalue(summaryClusters)
        clusterPlot <- tclvalue(plotClusters)
        hclustCall <- eval(parse(text=paste(solution,"$call",sep="")))
        string1 <- unlist(strsplit(as.character(hclustCall)[2], "\\("))
        string2 <- unlist(strsplit(string1[3], ","))
        form.vars <- string2[1]
        if(length(grep("\\[", string2[2])) == 0) {
            xmat <- paste("model.matrix(", form.vars, ", ", .activeDataSet, ")",
              sep="")
            }
        else {
            string3 <- unlist(strsplit(string2[2], "\\["))
            xmat <- paste("model.matrix(", form.vars, ", ", .activeDataSet, "[",
              string3[2], ", ]",")", sep="")
            }
        if (clusterSummary == "1") {
            doItAndPrint(paste("summary(as.factor(", clusterVar,
              ")) # Cluster Sizes", sep=""))
            centroidsCommand <- paste("by(", xmat, ", as.factor(", clusterVar,
              "), mean) # Cluster Centroids", sep="")
            doItAndPrint(centroidsCommand)
            }
        if (clusterPlot == "1") {
             plotCommand <- paste("biplot(princomp(", xmat, 
               "), xlabs = as.character(", clusterVar, "))", sep="")
            justDoIt(plotCommand)
            logger(plotCommand)
            }
        if(.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        tkfocus(.commander)
        } 
    OKCancelHelp(helpSubject="biplot")
    tkgrid(tklabel(optionsFrame, text="Number of clusters:"), slider,
      sticky="sw")
    tkgrid(tklabel(optionsFrame, 
      text="Print cluster summary"), summaryCB, sticky="w")
    tkgrid(tklabel(optionsFrame, 
      text="Bi-plot of clusters"), plotCB, sticky="w")
    tkgrid(getFrame(hclustBox), optionsFrame, sticky="nw")
    tkgrid(buttonsFrame, columnspan=2, sticky="w")
    dialogSuffix(rows=2, columns=3)
    }

appendHclustGroup <- function(){
    if(!checkActiveDataSet()) return()
    parseDataSet <- function(x) {
        y <- eval(parse(text=paste(x, "$call", sep="")))
        string1 <- unlist(strsplit(as.character(y)[2], "\\("))
        string2 <- unlist(strsplit(string1[3], ","))
        if(length(grep("\\[", string2[2])) == 0) {
            out <- gsub(")", "", gsub(" ", "", gsub("\\^2", "",
                string2[2])))
            }
        else {
            string3 <- unlist(strsplit(string2[2], "\\["))
            out <- gsub(" ", "", string3[1])
            }
        return(out)
        }
    hclustObjects <- listHclustSolutions()
    if(length(hclustObjects)==0) {
        tkmessageBox(message="There are no hierachical clustering solutions", 
            icon = "error", type = "ok", default = "ok")
        return()
        }    
    testDataSet <- tapply(hclustObjects, as.factor(1:length(hclustObjects)),
      parseDataSet)
    validHclust <- hclustObjects[testDataSet==.activeDataSet]
    if(length(validHclust)==0) {
        tkmessageBox(message="No hierachical clustering solutions are associated with this data set.", 
            icon = "error", type = "ok", default = "ok")
        return()
        }
    initializeDialog(
      title="Append Cluster Groups to the Active Data Set")
    hclustBox <- variableListBox(top, validHclust, selectmode="single",
      title="Select One Clustering Solution")
    optionsFrame <- tkframe(top)
    labelName <- tclVar("hclus.label")
    labelNameField <- tkentry(optionsFrame, width="15",
      textvariable=labelName)
    clusterNumber <- tclVar("2")
    slider <- tkscale(optionsFrame, from=2, to=10, showvalue=TRUE,
      variable=clusterNumber, resolution=1, orient="horizontal")
   onOK <- function(){
        solution <- getSelection(hclustBox)
        if(length(solution)==0) {
          errorCondition(recall=appendHclustGroup,
            message="A clustering solution has not been selected.")
          return()
            }
        clusters <- as.numeric(tclvalue(clusterNumber))
        label <- trim.blanks(tclvalue(labelName))
        if (is.element(label, .variables)) {
            if ("no" == tclvalue(checkReplace(label))){
                if (.grab.focus) tkgrab.release(top)
                tkdestroy(top)
                appendHclustGroup()
                return()
                }
            }        
        hclustCall <- eval(parse(text=paste(solution,"$call",sep="")))
        string1 <- unlist(strsplit(as.character(hclustCall)[2], "\\("))
        string2 <- unlist(strsplit(string1[3], ","))
        form.vars <- string2[1]
        if(length(grep("\\[", string2[2])) == 0) {
            xmat <- paste("model.matrix(", form.vars, ", ", .activeDataSet, ")",
              sep="")
            }
        else {
            string3 <- unlist(strsplit(string2[2], "\\["))
            xmat <- paste("model.matrix(", form.vars, ", ", .activeDataSet, "[",
              string3[2], ", ]",")", sep="")
            }
        clusterVar <- paste("cutree(", solution, ", k = ", clusters, ")",
          sep="")
        command <- paste(.activeDataSet, "$", label, " <- assignCluster(",
          xmat, ", ", .activeDataSet, ", ", clusterVar, ")", sep="")
        justDoIt(command)
        logger(command)
        activeDataSet(.activeDataSet)
        if(.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        tkfocus(.commander)
        } 
    OKCancelHelp(helpSubject="assignCluster")
    tkgrid(tklabel(optionsFrame, text="  Assigned cluster label:"),
      labelNameField, sticky="w")
    tkgrid(tklabel(optionsFrame, text="  Number of clusters:"),
        slider, sticky="sw")
    tkgrid(getFrame(hclustBox), optionsFrame, sticky="nw")
    tkgrid(buttonsFrame, columnspan=2, sticky="w")
    dialogSuffix(rows=2, columns=3)
    }
# The R Commander and command logger

# last modified 17 Jan 04 by J. Fox
#   slight changes 12 Aug 04 by Ph. Grosjean

Commander <- function(){
    if (is.SciViews()) return(invisible(svCommander())) # +PhG
    setOption <- function(option, default, global=TRUE) {
        opt <- if (is.null(current[[option]])) default else current[[option]]
        if (global) assign(paste(".", option, sep=""), opt, envir=.GlobalEnv)
        else opt
        }
    etc <- file.path(.path.package(package="Rcmdr")[1], "etc")
    onCopy <- function(){
        focused <- tkfocus()
        if ((tclvalue(focused) != .log$ID) && (tclvalue(focused) != .output$ID)) 
            focused <- .log
        selection <- strsplit(tclvalue(tktag.ranges(focused, "sel")), " ")[[1]]
        if (is.na(selection[1])) return()
        text <- tclvalue(tkget(focused, selection[1], selection[2]))
        tkclipboard.clear()
        tkclipboard.append(text)
        }    
    onDelete <- function(){
        focused <- tkfocus()
        if ((tclvalue(focused) != .log$ID) && (tclvalue(focused) != .output$ID))  
            focused <- .log
        selection <- strsplit(tclvalue(tktag.ranges(focused, "sel")), " ")[[1]]
        if (is.na(selection[1])) return()
        tkdelete(focused, selection[1], selection[2])
        }        
    onCut <- function(){
        onCopy()
        onDelete()
        }        
    onPaste <- function(){
        focused <- tkfocus()
        if ((tclvalue(focused) != .log$ID) && (tclvalue(focused) != .output$ID))  
            focused <- .log
        text <- tclvalue(.Tcl("selection get -selection CLIPBOARD"))    
        if (length(text) == 0) return()
        tkinsert(focused, "insert", text)
        }       
    onFind <- function(){
        focused <- tkfocus()
        if ((tclvalue(focused) != .log$ID) && (tclvalue(focused) != .output$ID))  
            focused <- .log
        initializeDialog(title="Find")
        textFrame <- tkframe(top)
        textVar <- tclVar("")
        textEntry <- tkentry(textFrame, width="20", textvariable=textVar)
        checkBoxes(frame="optionsFrame", boxes=c("regexpr", "case"), initialValues=c("0", "1"), 
            labels=c("Regular-expression search", "Case sensitive"))
        radioButtons(name="direction", buttons=c("foward", "backward"), labels=c("Forward", "Backward"),
            values=c("-forward", "-backward"), title="Search Direction")
        onOK <- function(){
            text <- tclvalue(textVar)
            if (text == ""){
                errorCondition(recall=onFind, message="No search text specified.")
                return()
                }
            type <- if (tclvalue(regexprVariable) == 1) "-regexp" else "-exact"
            case <- tclvalue(caseVariable) == 1
            direction <- tclvalue(directionVariable)
            stop <- if (direction == "-forward") "end" else "1.0"
            where <- if (case) tksearch(focused, type, direction, "--", text, "insert", stop)
                        else tksearch(focused, type, direction, "-nocase", "--", text, "insert", stop)
            where <- tclvalue(where)
            if (where == "") {
                tkmessageBox(message="Text not found.",
                    icon="info", type="ok")
                if (.grab.focus) tkgrab.release(top)
                tkdestroy(top)
                tkfocus(.commander)
                return()
                }
            if (.grab.focus) tkgrab.release(top)
            tkfocus(focused)
            tkmark.set(focused, "insert", where)  
            tksee(focused, where)
            tkdestroy(top)  
            }
        OKCancelHelp()
        tkgrid(tklabel(textFrame, text="Search for:"), textEntry, sticky="w") 
        tkgrid(textFrame, sticky="w") 
        tkgrid(optionsFrame, sticky="w")
        tkgrid(directionFrame, sticky="w")
        tkgrid(buttonsFrame, sticky="w")
        dialogSuffix(rows=4, columns=1, focus=textEntry)
         }    
    onSelectAll <- function() {
        focused <- tkfocus()
        if ((tclvalue(focused) != .log$ID) && (tclvalue(focused) != .output$ID))  
            focused <- .log
        tktag.add(focused, "sel", "1.0", "end")
        tkfocus(focused)
        }
    onClear <- function(){
        onSelectAll()
        onDelete()
        }
#    assign(".messages.connection", textConnection(".messages", open = "w"), envir=.GlobalEnv)
#    sink(.messages.connection, type="message")
#    assign(".length.messages", 0, envir=.GlobalEnv)
    assign(".activeDataSet", NULL, envir=.GlobalEnv)
    assign(".activeModel", NULL, envir=.GlobalEnv)
    assign(".logFileName", NULL, envir=.GlobalEnv)
    assign(".outputFileName", NULL, envir=.GlobalEnv)
    assign(".saveFileName", NULL, envir=.GlobalEnv)
    assign(".modelNumber", 0, envir=.GlobalEnv)
    assign(".rgl", FALSE, envir=.GlobalEnv)
    current <- options("Rcmdr")[[1]]
    setOption("log.font.size", 10)
    assign(".logFont", tkfont.create(family="courier", size=.log.font.size), envir=.GlobalEnv)
    assign(".operatorFont", tkfont.create(family="courier", size=.log.font.size), 
        envir=.GlobalEnv)
    scale.factor <- current$scale.factor
    if (!is.null(scale.factor)) .Tcl(paste("tk scaling ", scale.factor, sep=""))
    setOption("contrasts", c("contr.Treatment", "contr.poly"))
    setOption("log.commands", TRUE)
    setOption("console.output", FALSE)
    log.height <- as.character(setOption("log.height", if (!.log.commands) 0 else 10, global=FALSE))
    log.width <- as.character(setOption("log.width", 80, global=FALSE))
    output.height <- as.character(setOption("output.height",
        if (.console.output) 0
        else if ((as.numeric(log.height) != 0) || (!.log.commands)) 2*as.numeric(log.height)
        else 20, global=FALSE))
    assign(".saveOptions", options(warn=1, contrasts=.contrasts, width=as.numeric(log.width),
        na.action="na.exclude", graphics.record=TRUE), envir=.GlobalEnv) 
    setOption("double.click", FALSE)
    setOption("sort.names", TRUE)
#    setOption("grab.focus", .Platform$OS.type == "windows")
    setOption("grab.focus", TRUE)
    setOption("attach.data.set", TRUE)
    setOption("log.text.color", "black")
    setOption("command.text.color", "red")
    setOption("output.text.color", "darkblue")
    setOption("multiple.select.mode", "extended")
    setOption("report.X11.warnings", FALSE) # to address problem in Linux
    setOption("showData.threshold", 100)
    if (.Platform$OS.type != "windows") {
        assign(".oldPager", options(pager=RcmdrPager), envir=.GlobalEnv)
        default.font.size <- as.character(setOption("default.font.size", 10, global=FALSE))
        default.font <- setOption("default.font", 
            paste("*helvetica-medium-r-normal-*-", default.font.size, "*", sep=""), global=FALSE)
        .Tcl(paste("option add *font ", default.font, sep=""))
        } 
    assign(".commander", tktoplevel(), envir=.GlobalEnv)
    placement <- setOption("placement", "-40+40", global=FALSE)
    tkwm.geometry(.commander, placement)
    tkwm.title(.commander, "R Commander")
    tkwm.protocol(.commander, "WM_DELETE_WINDOW", closeCommander)
    topMenu <- tkmenu(.commander)
    tkconfigure(.commander, menu=topMenu)
    .commander.done <<- tclVar("0") # to address problem in Debian Linux
    source.files <- list.files(etc, pattern="\\.[Rr]$")
    for (file in source.files) {
        source(file.path(etc, file))
        cat(paste("Sourced:", file, "\n"))
        }
    Menus <- read.table(file.path(etc, "Rcmdr-menus.txt"), as.is=TRUE)
    for (m in 1:nrow(Menus)){
        if (Menus[m, 1] == "menu") assign(Menus[m, 2], tkmenu(eval(parse(text=Menus[m, 3])), tearoff=FALSE)) 
        else if (Menus[m, 1] == "item") {
            if (Menus[m, 3] == "command")
                tkadd(eval(parse(text=Menus[m, 2])),"command", label=Menus[m, 4], command=eval(parse(text=Menus[m, 5])))
            else if (Menus[m, 3] == "cascade")
                tkadd(eval(parse(text=Menus[m, 2])),"cascade", label=Menus[m, 4], menu=eval(parse(text=Menus[m, 5])))
            else stop(paste("menu defintion error:", Menus[m, ], collapse=" "))
            }
        else stop(paste("menu defintion error:", Menus[m, ], collapse=" "))
        }
    exceptions <- scan(file.path(etc, "log-exceptions.txt"), what="", quiet=TRUE, comment.char="#")
    assign(".modelClasses", scan(file.path(etc, "model-classes.txt"), what="", quiet=TRUE, comment.char="#"),
        envir=.GlobalEnv)
    onEdit <- function(){
        if (activeDataSet() == FALSE) {
            tkfocus(.commander)
            return()
            }
        command <- paste("fix(", .activeDataSet, ")", sep="")
        logger(command)
        justDoIt(command)
        activeDataSet(.activeDataSet)
        tkwm.deiconify(.commander)
        tkfocus(.commander)
        }
    onView <- function(){
        if (activeDataSet() == FALSE) {
            tkfocus(.commander)
            return()
            }
        view.height <- max(as.numeric(output.height) + as.numeric(log.height), 10)
        ncols <- eval(parse(text=paste("ncol(", .activeDataSet, ")")))
        command <- if (ncols <= .showData.threshold)
            paste("showData(", .activeDataSet, ", placement='-20+200', font=.logFont, maxwidth=", 
                log.width, ", maxheight=", view.height, ")", sep="")
            else paste("invisible(edit(", .activeDataSet, "))", sep="")
        logger(command)
        justDoIt(command)
        tkwm.deiconify(.commander)
        tkfocus(.commander)
        }
    onSubmit <- function(){
        selection <- strsplit(tclvalue(tktag.ranges(.log, "sel")), " ")[[1]]
        if (is.na(selection[1])) {
            tktag.add(.log, "currentLine", "insert linestart", "insert lineend")
            selection <- strsplit(tclvalue(tktag.ranges(.log, "currentLine")), " ")[[1]]
            tktag.delete(.log, "currentLine")
            if (is.na(selection[1])) {
                tkmessageBox(message=paste("Nothing is selected."),
                    icon="error", type="ok")
                tkfocus(.commander)
                return()
                }
            }
        lines <- tclvalue(tkget(.log, selection[1], selection[2]))
        lines <- strsplit(lines, "\n")[[1]]
        if (!.console.output) tkinsert(.output, "end", "\n")
        iline <- 1
        nlines <- length(lines)
        while (iline <= nlines){
            current.line <- lines[iline]
            if (.console.output) cat(paste("\nRcmdr> ", current.line,"\n", sep=""))
            else{
                tkinsert(.output, "end", paste("> ", current.line,"\n", sep=""))
                tktag.add(.output, "currentLine", "end - 2 lines linestart", "end - 2 lines lineend")
                tktag.configure(.output, "currentLine", foreground=.command.text.color)
                }
            jline <- iline + 1
            while (jline <= nlines){
                if (length(grep("^[\\ \t]", lines[jline])) == 0) break
                if (.console.output)cat(paste("Rcmdr+ ", lines[jline],"\n", sep=""))
                else{
                    tkinsert(.output, "end", paste("+ ", lines[jline],"\n", sep=""))
                    tktag.add(.output, "currentLine", "end - 2 lines linestart", "end - 2 lines lineend")
                    tktag.configure(.output, "currentLine", foreground=.command.text.color)
                    }
                current.line <- paste(current.line, lines[jline])
                jline <- jline + 1
                iline <- iline + 1
                }
            if (length(grep("<-", current.line)) > 0){
                var.value <- strsplit(current.line, "<-")[[1]]
                var <- gsub(" ", "", var.value[1])
                value <- var.value[2]
                if ( (length(grep("\\$", var)) > 0) || (length(grep("\\[", var)) > 0) 
                    || length(grep("\\(", var) > 0))
                    justDoIt(paste(var, "<-", value))
                else assign(var, justDoIt(value), envir=.GlobalEnv)
                }
            else if (length(grep("^remove\\(", current.line)) > 0){
                current.line <- sub(")", ", envir=.GlobalEnv)", current.line)
                justDoIt(current.line)
                }
            else if (length(grep("^hist\\(", current.line)) > 0){ 
                justDoIt(paste("plot(", current.line, ")", sep=""))
                }
            else if (any(sapply(exceptions, 
                    function(.x) length(grep(paste("^", .x, "\\(", sep=""), current.line)) > 0))){ 
                justDoIt(current.line)
                }
            else doItAndPrint(current.line, log=FALSE)
            iline <- iline + 1
            }
        tkyview.moveto(.output, 1)
        }
    contextMenuLog <- function(){
        contextMenu <- tkmenu(tkmenu(.log), tearoff=FALSE)
        tkadd(contextMenu, "command", label="Clear window", command=onClear)
        tkadd(contextMenu, "command", label="Submit", command=onSubmit)
        tkadd(contextMenu, "command", label="Cut", command=onCut)
        tkadd(contextMenu, "command", label="Copy", command=onCopy)
        tkadd(contextMenu, "command", label="Paste", command=onPaste)
        tkadd(contextMenu, "command", label="Delete", command=onDelete)
        tkadd(contextMenu, "command", label="Find...", command=onFind)
        tkadd(contextMenu, "command", label="Select all", command=onSelectAll)
        tkpopup(contextMenu, tkwinfo("pointerx", .log), tkwinfo("pointery", .log))
        }  
    contextMenuOutput <- function(){
        contextMenu <- tkmenu(tkmenu(.output), tearoff=FALSE)
        tkadd(contextMenu, "command", label="Clear window", command=onClear)
        tkadd(contextMenu, "command", label="Cut", command=onCut)
        tkadd(contextMenu, "command", label="Copy", command=onCopy)
        tkadd(contextMenu, "command", label="Paste", command=onPaste)
        tkadd(contextMenu, "command", label="Delete", command=onDelete)
        tkadd(contextMenu, "command", label="Find...", command=onFind)
        tkadd(contextMenu, "command", label="Select all", command=onSelectAll)
        tkpopup(contextMenu, tkwinfo("pointerx", .output), tkwinfo("pointery", .output))
        }    
    controlsFrame <- tkframe(.commander)
    editButton <- tkbutton(controlsFrame, text="Edit data set", command=onEdit)
    viewButton <- tkbutton(controlsFrame, text="View data set", command=onView)
    submitButton <- tkbutton(.commander, bitmap=paste("@", file.path(etc, "submit.xbm"), sep=""), 
        borderwidth="2", command=onSubmit)
    assign(".dataSetName", tclVar("<No active dataset>"), envir=.GlobalEnv)
    assign(".dataSetLabel", tkbutton(controlsFrame, textvariable=.dataSetName, fg="red",
        relief="groove", command=selectActiveDataSet),
        envir=.GlobalEnv)
    logFrame <- tkframe(.commander)
    assign(".log", tktext(logFrame, bg="white", fg=.log.text.color, font=.logFont, 
        height=log.height, width=log.width, wrap="none"),  envir=.GlobalEnv)
    logXscroll <- tkscrollbar(logFrame, repeatinterval=5, orient="horizontal",
        command=function(...) tkxview(.log, ...))
    logYscroll <- tkscrollbar(logFrame, repeatinterval=5,
        command=function(...) tkyview(.log, ...))
    tkconfigure(.log, xscrollcommand=function(...) tkset(logXscroll, ...))
    tkconfigure(.log, yscrollcommand=function(...) tkset(logYscroll, ...))
    outputFrame <- tkframe(.commander)
    assign(".output", tktext(outputFrame, bg="white", fg=.output.text.color, font=.logFont, 
        height=output.height, width=log.width, wrap="none"),  envir=.GlobalEnv)
    outputXscroll <- tkscrollbar(outputFrame, repeatinterval=5, orient="horizontal",
        command=function(...) tkxview(.output, ...))
    outputYscroll <- tkscrollbar(outputFrame, repeatinterval=5,
        command=function(...) tkyview(.output, ...))
    tkconfigure(.output, xscrollcommand=function(...) tkset(outputXscroll, ...))
    tkconfigure(.output, yscrollcommand=function(...) tkset(outputYscroll, ...))    
    assign(".modelName", tclVar("<No active model>"), envir=.GlobalEnv)
    assign(".modelLabel", tkbutton(controlsFrame, textvariable=.modelName, fg="red",
        relief="groove", command=selectActiveModel), 
        envir=.GlobalEnv)
    show.edit.button <- options("Rcmdr")[[1]]$show.edit.button
    show.edit.button <- if (is.null(show.edit.button)) TRUE else show.edit.button
    tkgrid(tklabel(controlsFrame, bitmap=paste("@", file.path(etc, "Rcmdr.xbm"), sep=""), fg="red"), 
        tklabel(controlsFrame, text="Data set:"), .dataSetLabel, 
        tklabel(controlsFrame, text="  "), if(show.edit.button) editButton, viewButton, 
        tklabel(controlsFrame, text="    Model: "), .modelLabel, sticky="w")
    tkgrid(controlsFrame, if (.log.commands) submitButton, sticky="w")
    if (.log.commands) tkgrid.configure(submitButton, sticky="e")
    tkgrid(.log, logYscroll, sticky="news")
    tkgrid(logXscroll)
    if (.log.commands) tkgrid(logFrame, sticky="news", padx=10, pady=10, columnspan=2)
    tkgrid(.output, outputYscroll, sticky="news")
    tkgrid(outputXscroll)
    if (!.console.output) tkgrid(outputFrame, sticky="news", padx=10, pady=10, columnspan=2)   
    tkgrid.configure(logYscroll, sticky="ns")
    tkgrid.configure(logXscroll, sticky="ew")   
    tkgrid.configure(outputYscroll, sticky="ns")
    tkgrid.configure(outputXscroll, sticky="ew")    
    tkgrid.rowconfigure(.commander, 0, weight=0)
    tkgrid.rowconfigure(.commander, 1, weight=1)
    tkgrid.rowconfigure(.commander, 2, weight=1)
    tkgrid.columnconfigure(.commander, 0, weight=1)
    tkgrid.columnconfigure(.commander, 1, weight=0)
    if (.log.commands){
        tkgrid.rowconfigure(logFrame, 0, weight=1)
        tkgrid.rowconfigure(logFrame, 1, weight=0)
        tkgrid.columnconfigure(logFrame, 0, weight=1)
        tkgrid.columnconfigure(logFrame, 1, weight=0)
        }
    if (!.console.output){
        tkgrid.rowconfigure(outputFrame, 0, weight=1)
        tkgrid.rowconfigure(outputFrame, 1, weight=0)
        tkgrid.columnconfigure(outputFrame, 0, weight=1)
        tkgrid.columnconfigure(outputFrame, 1, weight=0)
        }    
    .Tcl("update idletasks")
    tkbind(.commander, "<Control-r>", onSubmit)
    tkbind(.commander, "<Control-R>", onSubmit)
    tkbind(.commander, "<Control-f>", onFind)
    tkbind(.commander, "<Control-F>", onFind)
    tkbind(.commander, "<Control-s>", saveLog)
    tkbind(.commander, "<Control-S>", saveLog)
    tkbind(.log, "<ButtonPress-3>", contextMenuLog)
    tkbind(.output, "<ButtonPress-3>", contextMenuOutput)
    tkwm.deiconify(.commander)
    tkfocus(.commander)
    tkwait <- options("Rcmdr")[[1]]$tkwait  # to address problem in Debian Linux
    if ((!is.null(tkwait)) && tkwait) tkwait.variable(.commander.done)
    }

logger <- function(command){
    if (is.SciViews()) return(svlogger(command))    # +PhG
    if (.log.commands) {
        tkinsert(.log, "end", paste(command,"\n", sep=""))
        tkyview.moveto(.log, 1)
        }
    lines <- strsplit(command, "\n")[[1]]
    tkinsert(.output, "end", "\n")
    if (.console.output) for (line in lines) cat(paste("\nRcmdr>", line, "\n"))
    else {
        for (line in lines) tkinsert(.output, "end", paste("> ", command,"\n", sep=""))
        tktag.add(.output, "currentLine", "end - 2 lines linestart", "end - 2 lines lineend")
        tktag.configure(.output, "currentLine", foreground=.command.text.color)
        tkyview.moveto(.output, 1)
        }
    command
    }

justDoIt <- function(command) {
    messages.connection<- textConnection("messages", open="w")
    sink(messages.connection, type="message")
    on.exit({
        sink(type="message")
        close(messages.connection)
        })
    capture.output(result <- try(eval(parse(text=command), envir=.GlobalEnv), silent=TRUE))
    if (class(result)[1] ==  "try-error"){
        tkmessageBox(message=paste("Error:",
            strsplit(result, ":")[[1]][2]), icon="error")
        tkfocus(.commander)
        return()
        }
    checkWarnings(messages)
    result
    }

doItAndPrint <- function(command, log=TRUE) {
    messages.connection <- textConnection("messages", open="w")
    sink(messages.connection, type="message")
    output.connection <- textConnection("output", open="w")
    sink(output.connection, type="output")
    on.exit({
        sink(type="message")
        if (!.console.output) sink(type="output") # if .console.output, output connection already closed
        close(messages.connection)
        close(output.connection)
        })
    if (log) logger(command)
    result <-  try(eval(parse(text=command), envir=.GlobalEnv), silent=TRUE)
    if (class(result)[1] ==  "try-error"){
        tkmessageBox(message=paste("Error:",
            strsplit(result, ":")[[1]][2]), icon="error")
        if (.console.output) sink(type="output")
        tkfocus(.commander)
        return()
        }
    if (isS4object(result)) show(result) else print(result)
    if (output[length(output)] == "NULL") output <- output[-length(output)] # suppress "NULL" line at end of output
    if (length(output) != 0) {  # is there output to print?
        if (.console.output) {
            out <- output
            sink(type="output")
            for (line in out) cat(paste(line, "\n", sep=""))
            }
        else{
            for (line in output) tkinsert(.output, "end", paste(line, "\n", sep=""))
            tkyview.moveto(.output, 1)
            }
        }
    else if (.console.output) sink(type="output")
    checkWarnings(messages)  # errors already intercepted, display any warnings
    result
    }

checkWarnings <- function(messages){
    if (is.SciViews()) return(invisible()) # PhG: added for SciViews compatibility 
    if (length(messages) == 0) return()
    # suppress X11 warnings (origin at this point unclear)
    X11.warning <- grep("^Warning\\: X11 protocol error\\: BadWindow \\(invalid Window parameter\\)", messages)
    if ((length(X11.warning) > 0) && !.report.X11.warnings){
        messages <-messages[-X11.warning]
        if (length(messages) == 0) return()
        }
    if (length(messages) > 10) messages <- c(paste(length(messages), "warnings."),
        "First and last 5 warnings:", head(messages, 5), ". . .", tail(messages, 5))
    tkmessageBox(message=paste(messages, collapse="\n"), icon="warning")
    tkfocus(.commander)
    }
# last modified 15 Jan 2005 by J. Fox

# Data menu dialogs

newDataSet <- function() {
    initializeDialog(title="New Data Set")
    dsname <- tclVar("Dataset")
    entryDsname <- tkentry(top, width="20", textvariable=dsname)
    onOK <- function(){
        dsnameValue <- trim.blanks(tclvalue(dsname))
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        if (dsnameValue == "") {
            errorCondition(recall=newDataSet, 
                message="You must enter the name of a data set.")  
            return()
            }  
        if (!is.valid.name(dsnameValue)) {
            errorCondition(recall=newDataSet,
                message=paste('"', dsnameValue, '" is not a valid name.', sep=""))
            return()
            }
        if (is.element(dsnameValue, listDataSets())) {
            if ("no" == tclvalue(checkReplace(dsnameValue, "Data set"))){
                if (.grab.focus) tkgrab.release(top)
                tkdestroy(top)
                newDataSet()
                return()
                }
            }
        command <- "edit(as.data.frame(NULL))"
        assign(dsnameValue, justDoIt(command), envir=.GlobalEnv)
        logger(paste(dsnameValue, "<-", command))
        if (eval(parse(text=paste("nrow(", dsnameValue, ")"))) == 0){
            errorCondition(recall=newDataSet, message="empty data set.")
            return()
            }
        activeDataSet(dsnameValue)
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="edit.data.frame")
    tkgrid(tklabel(top, text="Enter name for data set:"), entryDsname, sticky="e")
    tkgrid(buttonsFrame, columnspan="2", sticky="w")
    tkgrid.configure(entryDsname, sticky="w")
    dialogSuffix(rows=2, columns=2, focus=entryDsname)
    }

selectActiveDataSet <- function(){
    dataSets <- listDataSets()
    if (length(dataSets) == 0){
        tkmessageBox(message="There are no data sets from which to choose.", 
                icon="error", type="ok")
        tkfocus(.commander)
        return()
        }
    initializeDialog(title="Select Data Set")   
    dataSetsBox <- variableListBox(top, dataSets, title="Data Sets (pick one)", 
        initialSelection=if (is.null(.activeDataSet)) NULL else which(.activeDataSet == dataSets) - 1)
    onOK <- function(){
        activeDataSet(getSelection(dataSetsBox))
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="attach")
    tkgrid(getFrame(dataSetsBox), sticky="nw")
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix(rows=2, columns=1)
    }
    
listDataSetsInPackages <- function() doItAndPrint("data()")

Recode <- function(){
    processRecode <- function(recode){
        parts <- strsplit(recode, "=")[[1]]
        if (length(grep(",", parts[1])) > 0) paste("c(", parts[1], ") = ", parts[2], sep="")
            else paste(parts, collapse="=")
        }
    if (!checkActiveDataSet()) return(invisible())
    dataSet <- activeDataSet()
    initializeDialog(title="Recode Variable")
    variablesBox <- variableListBox(top, .variables, title="Variable to recode (pick one)")
    variablesFrame <- tkframe(top)
    newVariableName <- tclVar("variable")
    newVariable <- tkentry(variablesFrame, width="20", textvariable=newVariableName)
    recodesFrame <- tkframe(top)
    recodes <- tktext(recodesFrame, bg="white", font=tkfont.create(family="courier", size=10), 
        height="5", width="40", wrap="none")
    recodesXscroll <- tkscrollbar(recodesFrame, repeatinterval=5, orient="horizontal",
        command=function(...) tkxview(recodes, ...))
    recodesYscroll <- tkscrollbar(recodesFrame, repeatinterval=5,
        command=function(...) tkyview(recodes, ...))
    tkconfigure(recodes, xscrollcommand=function(...) tkset(recodesXscroll, ...))
    tkconfigure(recodes, yscrollcommand=function(...) tkset(recodesYscroll, ...))
    asFactorFrame <- tkframe(top)
    asFactorVariable <- tclVar("1")
    asFactorCheckBox <- tkcheckbutton(asFactorFrame, variable=asFactorVariable)
    onOK <- function(){
        variable <- getSelection(variablesBox)
        if (length(variable) == 0) {
            errorCondition(recall=Recode, message="You must select a variable.")
            return()
            }
        newVar <- trim.blanks(tclvalue(newVariableName))
        if (!is.valid.name(newVar)){
            errorCondition(recall=Recode,
                message=paste('"', newVar, '" is not a valid name.', sep=""))
            return()
            }
        asFactor <- tclvalue(asFactorVariable) == "1"
        recode.directives <- gsub("\n", "; ", tclvalue(tkget(recodes, "1.0", "end")))
        check.empty <- gsub(";", "", gsub(" ", "", recode.directives))
        if ("" == check.empty) {
            errorCondition(recall=Recode,
                message="No recode directives specified.")
            return()
            }
        if (0 != length(grep("'", recode.directives))) {
            errorCondition(recall=Recode,
                message='Use only double-quotes (" ") in recode directives')
            return()
            }
        if (is.element(newVar, .variables)) {
            if ("no" == tclvalue(checkReplace(newVar))){
                if (.grab.focus) tkgrab.release(top)
                tkdestroy(top)
                Recode()
                return()
                }
            }
        recode.directives <- strsplit(recode.directives, ";")[[1]]
        recode.directives <- paste(sapply(recode.directives, processRecode), collapse=";") 
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        cmd <- paste("recode(", dataSet,"$",variable, ", '", recode.directives, 
            "', as.factor.result=", asFactor, ")", sep="")
        logger(paste(dataSet,"$",newVar, " <- ", cmd, sep=""))
        justDoIt(paste(dataSet,"$",newVar, " <- ", cmd, sep=""))
        activeDataSet(dataSet, flushModel=FALSE)
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="Recode")    
    tkgrid(getFrame(variablesBox), sticky="nw")
    tkgrid(tklabel(variablesFrame, text="New variable name"), sticky="w")
    tkgrid(newVariable, sticky="w")
    tkgrid(recodes, recodesYscroll, sticky="nw")
    tkgrid(recodesXscroll)
    tkgrid(variablesFrame, recodesFrame, sticky="nw")
    tkgrid(tklabel(asFactorFrame, text="Make new variable a factor"), asFactorCheckBox, 
        sticky="w")
    tkgrid(asFactorFrame, sticky="w")
    tkgrid(buttonsFrame, sticky="w", columnspan=2)
    tkgrid.configure(recodesXscroll, sticky="ew")
    tkgrid.configure(recodesYscroll, sticky="ns")
    dialogSuffix(rows=4, columns=2, bindReturn=FALSE)        
    }

Compute <- function(){
    if (!checkActiveDataSet()) return(invisible())
    dataSet <- activeDataSet()
    initializeDialog(title="Compute New Variable")
    variablesBox <- variableListBox(top, .variables, 
        title="Current variables (list only)", bg="gray", selectmode="browse")
    variablesFrame <- tkframe(top)
    newVariableName <- tclVar("variable")
    newVariable <- tkentry(variablesFrame, width="20", textvariable=newVariableName)
    computeFrame <- tkframe(top)
    computeVar <- tclVar("")
    compute <- tkentry(computeFrame, font=.logFont, width="30", textvariable=computeVar)
    computeXscroll <- tkscrollbar(computeFrame, repeatinterval=10,
        orient="horizontal", command=function(...) tkxview(compute, ...))
    tkconfigure(compute, xscrollcommand=function(...) tkset(computeXscroll, ...))
    onOK <- function(){
        newVar <- trim.blanks(tclvalue(newVariableName))
        if (!is.valid.name(newVar)){
            errorCondition(recall=Compute,
                message=paste('"', newVar, '" is not a valid name.', sep=""))
            return()
            }
        express <- tclvalue(computeVar)
        check.empty <- gsub(";", "", gsub(" ", "", express))
        if ("" == check.empty) {
            errorCondition(recall=Compute,
                message="No expression specified.")
            return()
            }
        if (is.element(newVar, .variables)) {
            if ("no" == tclvalue(checkReplace(newVar, "Variable"))){
                if (.grab.focus) tkgrab.release(top)
                tkdestroy(top)
                Compute()
                return()
                }
            }
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        logger(paste(dataSet,"$",newVar, " <- ", express, sep=""))
        justDoIt(paste(dataSet,"$",newVar, " <- with(", .activeDataSet,
            " ,", express, ")"))
        activeDataSet(dataSet, flushModel=FALSE)
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="Compute")
    tkgrid(getFrame(variablesBox), sticky="nw")       
    tkgrid(tklabel(variablesFrame, text="New variable name"), sticky="w")
    tkgrid(newVariable, sticky="w")
    tkgrid(tklabel(computeFrame, text="Expression to compute"), sticky="w")
    tkgrid(compute, sticky="w")
    tkgrid(computeXscroll, sticky="ew")
    tkgrid(variablesFrame, computeFrame, sticky="nw")
    tkgrid(buttonsFrame, sticky="w", columnspan=2)
    dialogSuffix(rows=3, columns=2)
    }

deleteVariable <- function(){
    if (!checkActiveDataSet()) return(invisible())
    dataSet <- activeDataSet()
    initializeDialog(title="Delete Variables")
    variablesBox <- variableListBox(top, .variables,
        title="Variable(s) to delete (pick one or more)", selectmode="multiple",
        initialSelection=NULL)
    onOK <- function(){
        variables <- getSelection(variablesBox)
        if (length(variables) == 0) {
            errorCondition(recall=deleteVariable, message="You must select one or more variables.")
            return()
            }
        if (length(variables) == 1){
            response <- tclvalue(tkmessageBox(message=paste("Delete ", variables,
                "?\nPlease confirm.", sep=""), icon="warning", type="okcancel", default="cancel"))
            if (response == "cancel") {
                onCancel()
                return()
                }
            }
        else{
            response <- tclvalue(tkmessageBox(message=paste("Delete ", length(variables),
                " variables?\nPlease confirm.", sep=""), 
                icon="warning", type="okcancel", default="cancel"))
            if (response == "cancel") {
                onCancel()
                return()
                }
            }  
        for (variable in variables){              
            eval(parse(text=paste(dataSet, "$", variable, "<- NULL", sep="")), envir=.GlobalEnv)
            logger(paste(dataSet, "$", variable, " <- NULL", sep=""))
            }
        activeDataSet(dataSet, flushModel=FALSE)
        if (.grab.focus) tkgrab.release(top)
        tkfocus(.commander)
        tkdestroy(top)  
        }
    OKCancelHelp(helpSubject="NULL")  
    tkgrid(getFrame(variablesBox), sticky="nw")
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix(rows=2, columns=1)
    }

readDataSet <- function() {
    initializeDialog(title="Read Data From Text File")
    optionsFrame <- tkframe(top)
    dsname <- tclVar("Dataset")
    entryDsname <- tkentry(optionsFrame, width="20", textvariable=dsname)
    headerVariable <- tclVar("1")
    headerCheckBox <- tkcheckbutton(optionsFrame, variable=headerVariable)
    radioButtons(optionsFrame, "delimiter", buttons=c("whitespace", "commas", "tabs"),
        labels=c("White space", "Commas", "Tabs"), title="Field Separator")
    otherButton <- tkradiobutton(delimiterFrame, variable=delimiterVariable, value="other")
    otherVariable <- tclVar("")
    otherEntry <- tkentry(delimiterFrame, width="4", textvariable=otherVariable) 
    radioButtons(optionsFrame, "decimal", buttons=c("period", "comma"),
        labels=c("Period [.]", "Comma [,]"), title="Decimal-Point Character")
    missingVariable <- tclVar("NA")
    missingEntry <- tkentry(optionsFrame, width="8", textvariable=missingVariable)    
    onOK <- function(){
        dsnameValue <- trim.blanks(tclvalue(dsname))
        if (dsnameValue == ""){
            errorCondition(recall=readDataSet,
                message="You must enter a name for the data set.")
                return()
                }
        if (!is.valid.name(dsnameValue)){
            errorCondition(recall=readDataSet,
                message=paste('"', dsnameValue, '" is not a valid name.', sep=""))
            return()
            }
        if (is.element(dsnameValue, listDataSets())) {
            if ("no" == tclvalue(checkReplace(dsnameValue, "Data set"))){
                if (.grab.focus) tkgrab.release(top)
                tkdestroy(top)
                readDataSet()
                return()
                }
            }
        file <- tclvalue(tkgetOpenFile(filetypes=
            '{"Text Files" {".txt" ".TXT" ".dat" ".DAT" ".csv" ".CSV"}} {"All Files" {"*"}}'))
        if (file == "") {
            if (.grab.focus) tkgrab.release(top)
            tkdestroy(top)
            return()
            }
        head <- tclvalue(headerVariable) == "1"
        delimiter <- tclvalue(delimiterVariable)
        del <- if (delimiter == "whitespace") ""
            else if (delimiter == "commas") ","
            else if (delimiter == "tabs") "\\t"
            else tclvalue(otherVariable)
        miss <- tclvalue(missingVariable)
        dec <- if (tclvalue(decimalVariable) == "period") "." else ","
        command <- paste('read.table("', file,'", header=', head, 
            ', sep="', del, '", na.strings="', miss, '", dec="', dec, '", strip.white=TRUE)', sep="")
        logger(paste(dsnameValue, " <- ", command, sep=""))
        assign(dsnameValue, justDoIt(command), envir=.GlobalEnv)
        activeDataSet(dsnameValue)
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="read.table")
    tkgrid(tklabel(optionsFrame, text="Enter name for data set:"), entryDsname, sticky="w")
    tkgrid(tklabel(optionsFrame, text="Variable names in file:"), headerCheckBox, sticky="w")
    tkgrid(tklabel(optionsFrame, text="Missing data indicator:"), missingEntry, sticky="w")
    tkgrid(tklabel(delimiterFrame, text="Other"), otherButton, 
        tklabel(delimiterFrame, text="  Specify:"), otherEntry, sticky="w")
    tkgrid(delimiterFrame, sticky="w", columnspan=2)
    tkgrid(decimalFrame, sticky="w")
    tkgrid(optionsFrame, sticky="w")
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix(rows=4, columns=1)
    }
    
readDataFromPackage <- function() {
    initializeDialog(title="Read Data From Package")
    dsname <- tclVar("")
    enterFrame <- tkframe(top)
    entryDsname <- tkentry(enterFrame, width="20", textvariable=dsname)
    packages <- sort(.packages())
    packagesBox <- variableListBox(top, packages, title="Select package:")
    onOK <- function(){
        dsnameValue <- tclvalue(dsname)
        if (dsnameValue != ""){
            if (is.element(dsnameValue, listDataSets())) {
                if ("no" == tclvalue(checkReplace(dsnameValue, "Data set"))){
                    if (.grab.focus) tkgrab.release(top)
                    tkdestroy(top)
                    readDataFromPackage()
                    return()
                    }
                }
            save.options <- options(warn=2)
            check <- try(eval(parse(text=logger(paste("data(", dsnameValue, ")", sep=""))),
                envir=.GlobalEnv), silent=TRUE)
            options(save.options)
            if (class(check) == "try-error"){
                errorCondition(recall=readDataFromPackage,
                    message=paste("Data set", dsnameValue, "does not exist."))
                return()
                }
            activeDataSet(dsnameValue)
            if (.grab.focus) tkgrab.release(top)
            tkdestroy(top)
            tkfocus(.commander)
            }
        else{
            packageName <- getSelection(packagesBox)
            if (length(packageName) == 0) {
                errorCondition(recall=readDataFromPackage, message="You must select a package.")
                return()
                }
            save.options <- options(warn=-1)
            dataSets <- data(package=packageName)$results[,3] 
            options(save.options)
            if (.grab.focus) tkgrab.release(top)
            tkdestroy(top)
            if (length(dataSets) == 0){
                errorCondition(recall=readDataFromPackage,
                    message=paste("There are no data sets in package", packageName))
                    return()
                }
            initializeDialog(subdialog, title="Select Data Set")
            dsBox <- variableListBox(subdialog, dataSets, title="Select data set")
            onOKsub <- function() {
                dsnameValue <- getSelection(dsBox)
                if (length(dsnameValue) == 0) {
                    if (.grab.focus) tkgrab.release(subdialog)
                    tkdestroy(subdialog)
                    errorCondition(recall=readDataFromPackage, message="You must select a data set")
                    return()
                    }
                if (is.element(dsnameValue, listDataSets())) {
                    if ("no" == tclvalue(checkReplace(dsnameValue, "Data set"))){
                        if (.grab.focus) tkgrab.release(subdialog)
                        tkdestroy(subdialog)
                        readDataFromPackage()
                        return()
                        }
                    }
                command <- paste("data(", dsnameValue, ', package="', packageName, '")', sep="")
                justDoIt(command)
                logger(command)
                activeDataSet(dsnameValue)                
                if (.grab.focus) tkgrab.release(subdialog)
                tkfocus(.commander)
                tkdestroy(subdialog)
                }
            subOKCancelHelp()         
            tkgrid(getFrame(dsBox), sticky="nw")
            tkgrid(subButtonsFrame, sticky="w")
            tkbind(dsBox$listbox, "<Double-ButtonPress-1>", onOKsub)
            dialogSuffix(subdialog, onOK=onOKsub, rows=4, columns=2, focus=subdialog)
            }
        }
    OKCancelHelp(helpSubject="data")
    tkgrid(tklabel(enterFrame, text="Enter name of data set:  ", fg="blue"), entryDsname, sticky="w")
    tkgrid(enterFrame, sticky="w")
    tkgrid(tklabel(top, text="OR", fg="red"), sticky="w")
    tkgrid(getFrame(packagesBox), sticky="nw")
    tkbind(packagesBox$listbox, "<Double-ButtonPress-1>", onOK)
    tkgrid(buttonsFrame, columnspan="2", sticky="w")
    dialogSuffix(rows=4, columns=1, focus=entryDsname)
    }
    
importSPSS <- function() {
    initializeDialog(title="Import SPSS Data Set")
    dsname <- tclVar("Dataset")
    entryDsname <- tkentry(top, width="20", textvariable=dsname)
    asFactor <- tclVar("1")
    asFactorCheckBox <- tkcheckbutton(top, variable=asFactor)
    maxLevels <- tclVar("Inf")
    entryMaxLevels <- tkentry(top, width="5", textvariable=maxLevels)
    onOK <- function(){
        dsnameValue <- trim.blanks(tclvalue(dsname))
        if (dsnameValue == ""){
            errorCondition(recall=importSPSS,
                message="You must enter the name of a data set.")
                return()
                }
        if (!is.valid.name(dsnameValue)){
            errorCondition(recall=importSPSS,
                message=paste('"', dsnameValue, '" is not a valid name.', sep=""))
            return()
            }                     
        if (is.element(dsnameValue, listDataSets())) {
            if ("no" == tclvalue(checkReplace(dsnameValue, "Data set"))){
                if (.grab.focus) tkgrab.release(top)
                tkdestroy(top)
                importSPSS()
                return()
                }
            }
        file <- tclvalue(tkgetOpenFile(
            filetypes='{"SPSS save files" {".sav" ".SAV"}} {"SPSS portable files" {".por" ".POR"}} {"All Files" {"*"}}'))
        if (file == "") {
            if (.grab.focus) tkgrab.release(top)
            tkdestroy(top)
            return()
            }
        factor <- tclvalue(asFactor) == "1"
        levels <- as.numeric(tclvalue(maxLevels))
        command <- paste('read.spss("', file,'", use.value.labels=', factor,
            ", max.value.labels=", levels, ", to.data.frame=TRUE)", sep="")
        logger(paste(dsnameValue, " <- ", command, sep=""))
        assign(dsnameValue, justDoIt(command), envir=.GlobalEnv)
        activeDataSet(dsnameValue)
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="read.spss")
    tkgrid(tklabel(top, text="Enter name for data set:"), entryDsname, sticky="w")
    tkgrid(tklabel(top, text="Convert value labels\nto factor levels", justify="left"), 
        asFactorCheckBox, sticky="w")
    tkgrid(tklabel(top, text="Maximum number\nof value labels\nfor factor conversion", justify="left"), 
        entryMaxLevels, sticky="w")
    tkgrid(buttonsFrame, columnspan="2", sticky="w")
    tkgrid.configure(entryDsname, sticky="w")
    tkgrid.configure(asFactorCheckBox, sticky="w")
    tkgrid.configure(entryMaxLevels, sticky="w")
    dialogSuffix(rows=4, columns=2, focus=entryDsname)
    }

importMinitab <- function() {
    initializeDialog(title="Import Minitab Data Set")
    dsname <- tclVar("Dataset")
    entryDsname <- tkentry(top, width="20", textvariable=dsname)
    onOK <- function(){
        dsnameValue <- trim.blanks(tclvalue(dsname))
        if (dsnameValue == ""){
            errorCondition(recall=importMinitab,
                message="You must enter the name of a data set.")
                return()
                }     
        if (!is.valid.name(dsnameValue)){
            errorCondition(recall=importMinitab,
                message=paste('"', dsnameValue, '" is not a valid name.', sep=""))
            return()
            }
        if (is.element(dsnameValue, listDataSets())) {
            if ("no" == tclvalue(checkReplace(dsnameValue, "Data set"))){
                if (.grab.focus) tkgrab.release(top)
                tkdestroy(top)
                importMinitab()
                return()
                }
            }
        file <- tclvalue(tkgetOpenFile(
            filetypes='{"Minitab portable files" {".mtp" ".MTP"}} {"All Files" {"*"}}'))
        if (file == "") {
            if (.grab.focus) tkgrab.release(top)
            tkdestroy(top)
            return()
            }
        command <- paste('read.mtp("', file,'")', sep="")
        datalist <- justDoIt(command)
        lengths <- sapply(datalist, length)
        datalist <- datalist[lengths != 0]
        lengths <- lengths[lengths != 0]
        if (!all(lengths == length(datalist[[1]]))){
            tkmessageBox(message=
                paste("Minitab data set contains elements of unequal length.\nData set cannot be converted."),
                icon="error", type="ok")
            tkdestroy(top)
            tkfocus(.commander)
            return()
            }
        assign(dsnameValue, as.data.frame(datalist), envir=.GlobalEnv)
        logger(paste(dsnameValue, " <- as.data.frame(", command, ")", sep=""))
        activeDataSet(dsnameValue)
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="read.mtp")
    tkgrid(tklabel(top, text="Enter name for data set:"), entryDsname, sticky="e")
    tkgrid(buttonsFrame, columnspan="2", sticky="w")
    tkgrid.configure(entryDsname, sticky="w")
    dialogSuffix(rows=2, columns=2, focus=entryDsname)
    }

# the following function was contributed by Michael Ash

importSTATA <- function() {
    initializeDialog(title="Import STATA Data Set")
    dsname <- tclVar("Dataset")
    entryDsname <- tkentry(top, width="20", textvariable=dsname)
    asFactor <- tclVar("1")
    asFactorCheckBox <- tkcheckbutton(top, variable=asFactor)
    asDate <- tclVar("1")
    asDateCheckBox <- tkcheckbutton(top, variable=asDate)
    asMissingType <- tclVar("1")
    asMissingTypeCheckBox <- tkcheckbutton(top, variable=asMissingType)
    asConvertUnderscore <- tclVar("1")
    asConvertUnderscoreCheckBox <- tkcheckbutton(top, variable=asConvertUnderscore)
    asWarnMissingLabels <- tclVar("1")
    asWarnMissingLabelsCheckBox <- tkcheckbutton(top, variable=asWarnMissingLabels)
    onOK <- function(){
        dsnameValue <- trim.blanks(tclvalue(dsname))
        if (dsnameValue == ""){
            errorCondition(recall=importSTATA,
                message="You must enter the name of a data set.")
                return()
                }
        if (!is.valid.name(dsnameValue)){
            errorCondition(recall=importSTATA,
                message=paste('"', dsnameValue, '" is not a valid name.', sep=""))
            return()
            }                     
        if (is.element(dsnameValue, listDataSets())) {
            if ("no" == tclvalue(checkReplace(dsnameValue, "Data set"))){
                if (.grab.focus) tkgrab.release(top)
                tkdestroy(top)
                importSTATA()
                return()
                }
            }
        file <- tclvalue(tkgetOpenFile(
            filetypes='{"STATA datasets" {".dta" ".DTA"}} {"All Files" {"*"}}'))
        if (file == "") {
            if (.grab.focus) tkgrab.release(top)
            tkdestroy(top)
            return()
            }
        convert.date <- tclvalue(asDate) == "1"
        factor <- tclvalue(asFactor) == "1"
        missingtype <- tclvalue(asMissingType) == "1"
        convertunderscore <- tclvalue(asConvertUnderscore) == "1"
        warnmissinglabels <- tclvalue(asWarnMissingLabels) == "1"
        command <- paste('read.dta("', file,'", convert.dates=', convert.date,
            ", convert.factors=", factor, ", missing.type=", missingtype, 
            ", convert.underscore=", convertunderscore, ", warn.missing.labels=TRUE)", sep="")
        logger(paste(dsnameValue, " <- ", command, sep=""))
        assign(dsnameValue, justDoIt(command), envir=.GlobalEnv)
        activeDataSet(dsnameValue)
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="read.dta")
    tkgrid(tklabel(top, text="Enter name for data set:"), entryDsname, sticky="w")
    tkgrid(tklabel(top, text="Convert value labels\nto factor levels", justify="left"), 
        asFactorCheckBox, sticky="w")
    tkgrid(tklabel(top, text="Convert dates to R format", justify="left"), 
        asDateCheckBox, sticky="w")
    tkgrid(tklabel(top, text="Multiple missing types (>=Stata 8)", justify="left"), 
        asMissingTypeCheckBox, sticky="w")
    tkgrid(tklabel(top, text="Convert underscore to period", justify="left"), 
        asConvertUnderscoreCheckBox, sticky="w")
    tkgrid(tklabel(top, text="Warn on missing labels", justify="left"), 
        asWarnMissingLabelsCheckBox, sticky="w")
    tkgrid(buttonsFrame, columnspan="2", sticky="w")
    tkgrid.configure(entryDsname, sticky="w")
    tkgrid.configure(asFactorCheckBox, sticky="w")
    tkgrid.configure(asDateCheckBox, sticky="w")
    tkgrid.configure(asMissingTypeCheckBox, sticky="w")
    tkgrid.configure(asWarnMissingLabelsCheckBox, sticky="w")
    dialogSuffix(rows=4, columns=2, focus=entryDsname)
    } 

numericToFactor <- function(){
    if (!checkActiveDataSet()) return()
    if (!checkNumeric()) return()
    initializeDialog(title="Convert Numeric Variable to Factor")
    variableBox <- variableListBox(top, .numeric, title="Variable (pick one)")
    radioButtons(name="levels", buttons=c("names", "numbers"), 
        labels=c("Supply level names", "Use numbers"), title="Factor Levels")
    factorName <- tclVar("<same as variable>")
    factorNameField <- tkentry(top, width="20", textvariable=factorName)
    onOK <- function(){
        variable <- getSelection(variableBox)
        if (length(variable) == 0) {
            errorCondition(recall=numericToFactor, message="You must select a variable.")
            return()
            }
        name <- trim.blanks(tclvalue(factorName))
        if (name == "<same as variable>") name <- variable
        if (!is.valid.name(name)){
            errorCondition(recall=numericToFactor,
                message=paste('"', name, '" is not a valid name.', sep=""))
            return()
            }
        if (is.element(name, .variables)) {
            if ("no" == tclvalue(checkReplace(name))){
                if (.grab.focus) tkgrab.release(top)
                tkdestroy(top)
                numericToFactor()
                return()
                }
            }
        levelsType <- tclvalue(levelsVariable)
        if (levelsType == "names"){
            values <- sort(unique(eval(parse(text=paste(.activeDataSet, "$", variable, sep="")),
                envir=.GlobalEnv)))
            nvalues <- length(values)
            if (nvalues > 30) {
                errorCondition(recall=numericToFactor,
                    message=paste("Number of levels (", nvalues, ") too large.", sep=""))
                return()
                }
            initializeDialog(subdialog, title="Level Names")
            names <- rep("", nvalues)
            onOKsub <- function() {
                for (i in 1:nvalues){
                    names[i] <- eval(parse(text=paste("tclvalue(levelName", i, ")", sep="")))
                    }
                if (length(unique(names)) != nvalues){
                    errorCondition(recall=numericToFactor,
                        message="Levels names are not unique.")
                    return()
                    }
                if (any(names == "")){
                    errorCondition(recall=numericToFactor,
                        message="A level name is empty.")
                    return()
                    }
                command <- paste("factor(", .activeDataSet, "$", variable,
                    ", labels=c(", paste(paste("'", names, "'", sep=""), collapse=","), "))", sep="")
                justDoIt(paste(.activeDataSet, "$", name, " <- ", command, sep=""))
                logger(paste(.activeDataSet,"$", name," <- ", command, sep=""))
                activeDataSet(.activeDataSet)
                if (.grab.focus) tkgrab.release(subdialog)
                tkfocus(.commander)
                tkdestroy(subdialog)
                }
            subOKCancelHelp()
            tkgrid(tklabel(subdialog, text="Numeric value"), tklabel(subdialog, text="Level name"), sticky="w")
            for (i in 1:nvalues){
                valVar <- paste("levelName", i, sep="")
                assign(valVar, tclVar(""))
                assign(paste("entry", i, sep=""), tkentry(subdialog, width="20", 
                    textvariable=eval(parse(text=valVar))))
                tkgrid(tklabel(subdialog, text=values[i]), eval(parse(text=paste("entry", i, sep=""))), sticky="w")
                }
            tkgrid(subButtonsFrame, sticky="w", columnspan=2)
            if (.grab.focus) tkgrab.release(top)
            tkdestroy(top)        
            dialogSuffix(subdialog, rows=nvalues+2, columns=2, focus=entry1, onOK=onOKsub)   
            }
        else{
            command <- paste("as.factor(", .activeDataSet, "$", variable, ")", sep="")
            justDoIt(paste(.activeDataSet, "$", name, " <- ", command, sep=""))
            logger(paste(.activeDataSet, "$", name," <- ", command, sep=""))
            activeDataSet(.activeDataSet, flushModel=FALSE)
            if (.grab.focus) tkgrab.release(top)
            tkdestroy(top)
            tkfocus(.commander)
            }
        }
    OKCancelHelp(helpSubject="factor")
    tkgrid(getFrame(variableBox), levelsFrame, sticky="nw")
    tkgrid(tklabel(top, text="Name for factor"), sticky="w")
    tkgrid(factorNameField, sticky="w")
    tkgrid(buttonsFrame, sticky="w", columnspan=2)
    tkgrid.configure(numbersButton, sticky="w")
    tkgrid.configure(namesButton, sticky="w")
    dialogSuffix(rows=4, columns=2, preventGrabFocus=TRUE)
    }

binVariable <- function(){
# Author: Dan Putler (revision by J. Fox, 24 July 04)
    if (!checkActiveDataSet()) return()
    if (!checkNumeric()) return()
    env <- environment()
    initializeDialog(title="Bin a Numeric Variable")
    variableFrame <- tkframe(top)
    variableBox <- variableListBox(variableFrame, .numeric, title="Variable to bin (pick one)")
    newVariableFrame <- tkframe(variableFrame)
    newVariableName <- tclVar("variable")
    newVariable <- tkentry(newVariableFrame, width="18", textvariable=newVariableName)
    binsFrame <- tkframe(top)
    binsVariable <- tclVar("3")
    slider <- tkscale(binsFrame, from=2, to=10, showvalue=TRUE, variable=binsVariable,
        resolution=1, orient="horizontal")
    optionsFrame <- tkframe(top)
    radioButtons(optionsFrame, name="levels", buttons=c("specify", "numbers", "ranges"),
        labels=c("Specify names", "Numbers", "Ranges"), title="Level Names")    
    radioButtons(optionsFrame, name="method", buttons=c("intervals", "proportions", "natural"),
        labels=c("Equal-width bins", "Equal-count bins", "Natural breaks\n(from K-means clustering)"),
        title="Binning Method")
    onOK <- function(){
        if (.grab.focus) tkgrab.release(top)
        levels <- tclvalue(levelsVariable)
        bins <- as.numeric(tclvalue(binsVariable))
        varName <- getSelection(variableBox)
        if (length(varName) == 0){
            errorCondition(recall=binVariable, message="You must select a variable.")
            return()
            }
        newVar <- tclvalue(newVariableName)
        if (is.element(newVar, .variables)) {
                if ("no" == tclvalue(checkReplace(newVar))){
                    if (.grab.focus) tkgrab.release(top)
                    tkdestroy(top)
                    binVariable()
                    return()
                    }
                }
        if (!is.valid.name(newVar)){
            errorCondition(message=paste('"', newVar, '" is not a valid name.', sep=""),
                recall=binVariable)
            return()
            }
        method <- tclvalue(methodVariable)
        if (levels == "specify"){
            if (.grab.focus) tkgrab.release(top)
            initializeDialog(subdialog, title="Bin Names")
            onOKsub <- function() {
                level <- character(bins)
                for (i in 1:bins){
                    level[i] <- eval(parse(text=paste("tclvalue(levelName", i, ")", sep="")))
                    }
                if (length(unique(level)) != length(level)){
                    errorCondition(window=subdialog, message="Level names must be unique.",
                        recall=onOK)
                    return()
                    }
                assign("levelNames", level, envir=env)
                if (.grab.focus) tkgrab.release(subdialog)
                tkdestroy(subdialog)
                }
            subOKCancelHelp()
            tkgrid(tklabel(subdialog, text="Bin", fg="blue"), 
                tklabel(subdialog, text="Name", fg="blue"), sticky="w")
            for (i in 1:bins){
                valVar <- paste("levelName", i, sep="")
                assign(valVar, tclVar(i))
                assign(paste("entry", i, sep=""), tkentry(subdialog, width="20", 
                    textvariable=eval(parse(text=valVar))))
                tkgrid(tklabel(subdialog, text=as.character(i)), eval(parse(text=paste("entry", i, sep=""))), sticky="w")
                }
            tkgrid(subButtonsFrame, sticky="w", columnspan=2)
            dialogSuffix(subdialog, focus=entry1, rows=bins+1, columns=2, bindReturn=FALSE)
            }
        labels <- if (levels == "numbers") "FALSE"
            else if (levels == "ranges") "NULL"
            else {
                if (!exists("levelNames")){
                    onCancel()
                    binVariable()
                    return()
                    }
                paste("c('", paste(levelNames,  collapse="','"), "')", sep="")
                }
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        command <- paste(.activeDataSet,"$",newVar, " <- ",
            "bin.var(", .activeDataSet,"$", varName, ", bins=", bins,
            ", method=", "'", method, "', labels=", labels, ")", sep="")
        logger(command)
        justDoIt(command)
        activeDataSet(.activeDataSet, flushModel=FALSE)
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="bin.var")
    tkgrid(tklabel(newVariableFrame, text="New variable name", fg="blue"), sticky="w") 
    tkgrid(newVariable, sticky="w")
    tkgrid(getFrame(variableBox), tklabel(variableFrame, text="    "), newVariableFrame, sticky="nw")
    tkgrid(variableFrame, sticky="w")
    tkgrid(tklabel(binsFrame, text="Number of bins:"), slider, sticky="s")
    tkgrid(binsFrame, sticky="w")
    tkgrid(levelsFrame, tklabel(optionsFrame, text="    "), methodFrame, sticky="nw")
    tkgrid(optionsFrame, sticky="w")
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix(rows=4, columns=1)
    }

reorderFactor <- function(){
    if (!checkActiveDataSet()) return()
    if (!checkFactors()) return()
    initializeDialog(title="Reorder Factor Levels")
    variableBox <- variableListBox(top, .factors, title="Factor (pick one)")
    orderedFrame <- tkframe(top)
    orderedVariable <- tclVar("0")
    orderedCheckBox <- tkcheckbutton(orderedFrame, variable=orderedVariable)
    factorName <- tclVar("<same as original>")
    factorNameField <- tkentry(top, width="20", textvariable=factorName)
    onOK <- function(){
        variable <- getSelection(variableBox)
        if (length(variable) == 0) {
            errorCondition(recall=reorderFactor, message="You must select a variable.")
            return()
            }
        name <- trim.blanks(tclvalue(factorName))
        if (name == "<same as original>") name <- variable
        if (!is.valid.name(name)){
            errorCondition(recall=reorderFactor,
                message=paste('"', name, '" is not a valid name.', sep=""))
            return()
            }
        if (is.element(name, .variables)) {
            if ("no" == tclvalue(checkReplace(name))){
                if (.grab.focus) tkgrab.release(top)
                tkdestroy(top)
                reorderFactor()
                return()
                }
            }
        old.levels <- eval(parse(text=paste("levels(", .activeDataSet, "$", variable, ")", 
            sep="")), envir=.GlobalEnv)
        nvalues <- length(old.levels)
        ordered <- tclvalue(orderedVariable)
        if (nvalues > 30) {
            errorCondition(recall=reorderFactor,
                message=paste("Number of levels (", nvalues, ") too large.", sep=""))
            return()
            }
        initializeDialog(subdialog, title="Reorder Levels")
        order <- 1:nvalues
        onOKsub <- function() {
            if (.grab.focus) tkgrab.release(top)
            tkdestroy(top)
            for (i in 1:nvalues){
                order[i] <- as.numeric(eval(parse(text=paste("tclvalue(levelOrder", i, ")", sep=""))))
                }
            if (any(sort(order) != 1:nvalues)){
                errorCondition(recall=reorderFactor,
                    message=paste("Order of levels must include all integers from 1 to ", nvalues, sep=""))
                return()
                }
            levels <- old.levels[order(order)]
            ordered <- if (ordered == "1") ", ordered=TRUE" else ""
            command <- paste("factor(", .activeDataSet, "$", variable,
                ", levels=c(", paste(paste("'", levels, "'", sep=""), collapse=","), ")",
                ordered, ")", sep="")
            justDoIt(paste(.activeDataSet, "$", name, " <- ", command, sep=""))
            logger(paste(.activeDataSet,"$", name," <- ", command, sep=""))
            activeDataSet(.activeDataSet, flushModel=FALSE)
            if (.grab.focus) tkgrab.release(subdialog)
            tkdestroy(subdialog)
            }
        subOKCancelHelp()
        tkgrid(tklabel(subdialog, text="Old Levels", fg="blue"), 
            tklabel(subdialog, text="New order", fg="blue"), sticky="w")
        for (i in 1:nvalues){
            valVar <- paste("levelOrder", i, sep="")
            assign(valVar, tclVar(i))
            assign(paste("entry", i, sep=""), tkentry(subdialog, width="2", 
                textvariable=eval(parse(text=valVar))))
            tkgrid(tklabel(subdialog, text=old.levels[i]), eval(parse(text=paste("entry", i, sep=""))), sticky="w")
            }
        tkgrid(subButtonsFrame, sticky="w", columnspan=2)
        dialogSuffix(subdialog, focus=entry1, rows=nvalues+1, columns=2)
        }
    OKCancelHelp(helpSubject="factor")
    tkgrid(getFrame(variableBox), sticky="nw")
    tkgrid(tklabel(top, text="Name for factor"), sticky="w")
    tkgrid(factorNameField, sticky="w")
    tkgrid(tklabel(orderedFrame, text="Make ordered factor"), orderedCheckBox, sticky="w")
    tkgrid(orderedFrame, sticky="w")
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix(rows=5, columns=1, preventGrabFocus=TRUE)
    }

standardize <- function(X){
    if (!checkActiveDataSet()) return()
    if (!checkNumeric()) return()
    initializeDialog(title="Standardize Variables")
    xBox <- variableListBox(top, .numeric, title="Variables (pick one or more)",
        selectmode="multiple")
    onOK <- function(){
        x <- getSelection(xBox)
        if (length(x) == 0) {
            errorCondition(recall=standardize, message="You must select one or more variables.")
            return()
            }
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        xx <- paste('"', x, '"', sep="")
        command <- paste("scale(", .activeDataSet, "[,c(", paste(xx, collapse=","),
            ")])", sep="")
        assign(".Z", justDoIt(command), envir=.GlobalEnv)
        logger(paste(".Z <- ", command, sep=""))
        for (i in 1:length(x)){
            Z <- paste("Z.", x[i], sep="")
            if (is.element(Z, .variables)) {
                if ("no" == tclvalue(checkReplace(Z))){
                    if (.grab.focus) tkgrab.release(top)
                    tkdestroy(top)
                    next
                    }
                }
            justDoIt(paste(.activeDataSet, "$", Z, " <- .Z[,", i, "]", sep=""))
            logger(paste(.activeDataSet, "$", Z, " <- .Z[,", i, "]", sep=""))
            }
        remove(.Z, envir=.GlobalEnv)   
        logger("remove(.Z)")
        activeDataSet(.activeDataSet, flushModel=FALSE)
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="scale")
    tkgrid(getFrame(xBox), sticky="w")
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix(rows=2, columns=1)
    }

helpDataSet <- function(){
    if (!checkActiveDataSet()) return()
    if (as.numeric(R.Version()$major) >= 2) doItAndPrint(paste('help("', .activeDataSet, '")', sep=""))
    else {
        justDoIt(paste("help('", .activeDataSet, "')", sep=""))
        logger(paste('help("', .activeDataSet, '")', sep=""))
        }
    NULL
    }
    
variablesDataSet <- function(){
    if (!checkActiveDataSet()) return()
    doItAndPrint(paste("names(", .activeDataSet, ")", sep=""))
    }

exportDataSet <- function() {
    if (!checkActiveDataSet()) return()
    dsname <- activeDataSet()
    initializeDialog(title="Export Active Data Set")
    checkBoxes(frame="optionsFrame", boxes=c("colnames", "rownames", "quotes"),
        initialValues=rep(1,3), labels=c("Write variable names:", "Write row names:", "Quotes around character values:"))
    missingVariable <- tclVar("NA")
    missingEntry <- tkentry(optionsFrame, width="8", textvariable=missingVariable)
    radioButtons(name="delimiter", buttons=c("spaces", "tabs", "commas"), labels=c("Spaces", "Tabs", "Commas"),
        title="Field Separator")
    onOK <- function(){
        col <- tclvalue(colnamesVariable) == 1
        row <- tclvalue(rownamesVariable) == 1
        quote <- tclvalue(quotesVariable) == 1
        delim <- tclvalue(delimiterVariable)
        missing <- tclvalue(missingVariable)
        sep <- if (delim == "tabs") "\\t"
            else if (delim == "spaces") " "
            else ","
        saveFile <- tclvalue(tkgetSaveFile(filetypes='{"Text Files" {".txt" ".TXT" ".dat" ".DAT" ".csv" ".CSV"}} {"All Files" {"*"}}',
            defaultextension="txt", initialfile=paste(dsname, ".txt", sep="")))
        if (saveFile == "") {
            if (.grab.focus) tkgrab.release(top)
            tkdestroy(top)
            tkfocus(.commander)
            return()
            }
        command <- paste("write.table(", dsname, ', "', saveFile, '", sep="', sep, 
            '", col.names=', col, ", row.names=", row, ", quote=", quote,
            ', na="', missing, '")', sep="")           
        justDoIt(command)
        logger(command)
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="write.table")
    tkgrid(tklabel(optionsFrame, text="Missing values:"), missingEntry, sticky="w")
    tkgrid(optionsFrame, sticky="w")
    tkgrid(delimiterFrame, stick="w")
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix(rows=3, columns=1)
    }

filterNA <- function(){
    if (!checkActiveDataSet()) return()
    dataSet <- activeDataSet()
    initializeDialog(title="Remove Missing Data")
    allVariablesFrame <- tkframe(top)
    allVariables <- tclVar("1")
    allVariablesCheckBox <- tkcheckbutton(allVariablesFrame, variable=allVariables)
    variablesBox <- variableListBox(top, .variables, selectmode="multiple", initialSelection=NULL,
        title="Variables (select one or more)")
    newDataSetName <- tclVar("<same as active data set>")
    dataSetNameFrame <- tkframe(top)
    dataSetNameEntry <- tkentry(dataSetNameFrame, width="25", textvariable=newDataSetName)
    onOK <- function(){
        newName <- trim.blanks(tclvalue(newDataSetName))
        if (newName == "<same as active data set>") newName <- .activeDataSet
        if (!is.valid.name(newName)){
            errorCondition(recall=filterNA,
                message=paste('"', newName, '" is not a valid name.', sep=""))
            return()
            }
        if (is.element(newName, listDataSets())) {
            if ("no" == tclvalue(checkReplace(newName, "Data set"))){
                if (.grab.focus) tkgrab.release(top)
                tkdestroy(top)
                filterNA()
                return()
                }
            }
        if (tclvalue(allVariables) == "1"){
            command <- paste(newName, " <- na.omit(", .activeDataSet, ")", sep="")
            logger(command)
            justDoIt(command)
            activeDataSet(newName)
            if (.grab.focus) tkgrab.release(top)
            tkdestroy(top)  
            tkfocus(.commander)
            }
        else {
            x <- getSelection(variablesBox)
            if (0 > length(x)) {
                errorCondition(recall=filterNA, message="No variables were selected.")
                return()
                }
            if (.grab.focus) tkgrab.release(top)
            tkdestroy(top)
            x <- paste('"', x, '"', sep="")
            command <- paste(newName, " <- na.omit(", .activeDataSet, "[,c(", paste(x, collapse=","),
                ')])', sep="")
            logger(command)
            justDoIt(command)
            activeDataSet(newName)
            tkfocus(.commander)
            }
        }
    OKCancelHelp(helpSubject="na.omit")
    tkgrid(tklabel(allVariablesFrame, text="Include all variables"), 
        allVariablesCheckBox, sticky="w")
    tkgrid(allVariablesFrame, sticky="w")
    tkgrid(tklabel(top, text="   OR", fg="red"), sticky="w")
    tkgrid(getFrame(variablesBox), sticky="nw")
    tkgrid(tklabel(dataSetNameFrame, text="Name for new data set"), sticky="w")
    tkgrid(dataSetNameEntry, sticky="w")
    tkgrid(dataSetNameFrame, sticky="w")
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix(rows=4, columns=1)
    }

subsetDataSet <- function(){
    if (!checkActiveDataSet()) return()
    dataSet <- activeDataSet()
    initializeDialog(title="Subset Data Set")
    allVariablesFrame <- tkframe(top)
    allVariables <- tclVar("1")
    allVariablesCheckBox <- tkcheckbutton(allVariablesFrame, variable=allVariables)
    variablesBox <- variableListBox(top, .variables, selectmode="multiple",
        initialSelection=NULL, title="Variables (select one or more)")
    subsetVariable <- tclVar("<all cases>")
    subsetFrame <- tkframe(top)
    subsetEntry <- tkentry(subsetFrame, width="20", textvariable=subsetVariable)
    subsetScroll <- tkscrollbar(subsetFrame, orient="horizontal",
        repeatinterval=5, command=function(...) tkxview(subsetEntry, ...))
    tkconfigure(subsetEntry, xscrollcommand=function(...) tkset(subsetScroll, ...))
    newDataSetName <- tclVar("<same as active data set>")
    dataSetNameFrame <- tkframe(top)
    dataSetNameEntry <- tkentry(dataSetNameFrame, width="25", textvariable=newDataSetName)
    onOK <- function(){
        newName <- trim.blanks(tclvalue(newDataSetName))
        if (newName == "<same as active data set>") newName <- .activeDataSet
        if (!is.valid.name(newName)){
            errorCondition(recall=subsetDataSet,
                message=paste('"', newName, '" is not a valid name.', sep=""))
            return()
            }
        if (is.element(newName, listDataSets())) {
            if ("no" == tclvalue(checkReplace(newName))){
                if (.grab.focus) tkgrab.release(top)
                tkdestroy(top)
                subsetDataSet()
                return()
                }
            }
        selectVars <- if (tclvalue(allVariables) == "1") ""
            else {
                x <- getSelection(variablesBox)
                if (0 > length(x)) {
                    errorCondition(recall=subsetDataSet,
                        message="No variables were selected.")
                    return()
                    }
                paste(", select=c(", paste(x, collapse=","), ")", sep="")
                }
        cases <- tclvalue(subsetVariable)
        selectCases <- if (cases == "<all cases>") ""
            else paste(", subset=", cases, sep="")
        if (selectVars == "" && selectCases ==""){
            errorCondition(recall=subsetDataSet,
                message="New data set same as active data set.")
            return()
            }
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        command <- paste(newName, " <- subset(", .activeDataSet, selectCases, selectVars, ")",
            sep="")
        logger(command)
        justDoIt(command)
        activeDataSet(newName)
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="subset")
    tkgrid(tklabel(allVariablesFrame, text="Include all variables"), 
        allVariablesCheckBox, sticky="w")
    tkgrid(allVariablesFrame, sticky="w")
    tkgrid(tklabel(top, text="   OR", fg="red"), sticky="w")
    tkgrid(getFrame(variablesBox), sticky="nw")
    tkgrid(tklabel(subsetFrame, text="Subset expression"), sticky="w")
    tkgrid(subsetEntry, sticky="w")
    tkgrid(subsetScroll, sticky="ew")
    tkgrid(subsetFrame, sticky="w")
    tkgrid(tklabel(dataSetNameFrame, text="Name for new data set"), sticky="w")
    tkgrid(dataSetNameEntry, sticky="w")
    tkgrid(dataSetNameFrame, sticky="w")
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix(rows=6, columns=1)
    }

setCaseNames <- function(){
    if (!checkActiveDataSet()) return()
    dataSet <- activeDataSet()
    initializeDialog(title="Set Case Names")
    variablesBox <- variableListBox(top, .variables, title="Select variable containing row names",
        initialSelection=NULL)
    onOK <- function(){
        variable <- getSelection(variablesBox)
        if (length(variable) == 0) {
            errorCondition(recall=setCaseNames, message="You must select a variable.")
            return()
            }
        var <- eval(parse(text=paste(dataSet, "$", variable, sep="")), envir=.GlobalEnv)
        if (length(var) != length(unique(var))){
            errorCondition(recall=setCaseNames, message="Case names must be unique.")
            return()
            }
        command <- paste("row.names(", dataSet, ") <- as.character(", dataSet, "$", variable, ")", sep="")
        justDoIt(command)
        logger(command)
        eval(parse(text=paste(dataSet, "$", variable, "<- NULL", sep="")), envir=.GlobalEnv)
        logger(paste(dataSet, "$", variable, " <- NULL", sep=""))
        activeDataSet(dataSet, flushModel=FALSE)
        if (.grab.focus) tkgrab.release(top)
        tkfocus(.commander)
        tkdestroy(top)  
        }
    OKCancelHelp(helpSubject="row.names")  
    tkgrid(getFrame(variablesBox), sticky="nw")
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix(rows=3, columns=1)
    }
    
renameVariables <- function(){
    if (!checkActiveDataSet()) return()
    initializeDialog(title="Rename Variables")
    variableBox <- variableListBox(top, .variables, title="Variables (pick one or more)",
        selectmode="multiple", initialSelection=NULL)
    onOK <- function(){
        variables <- getSelection(variableBox)
        nvariables <- length(variables)
        if (nvariables < 1) {
            errorCondition(recall=renameVariables, message="No variables selected.")
            return()
            }
        unordered.names <- names(eval(parse(text=.activeDataSet)))
        which.variables <- match(variables, unordered.names)
        initializeDialog(subdialog, title="Variable Names")
        newnames <- rep("", nvariables)
        onOKsub <- function() {
            for (i in 1:nvariables){
                newnames[i] <- eval(parse(text=paste("tclvalue(newName", i, ")", sep="")))
                }
            if (any(newnames == "")){
                errorCondition(recall=renameVariables, message="A variable name is empty.")
                return()
                }
            test.names <- newnames == make.names(newnames)
            if (!all(test.names)){
                errorCondition(recall=renameVariables,
                    message=paste("The following variable names are not valid:\n",
                    paste(newnames[!test.names], collapse=", ")))
                return()
                }                
            all.names <- eval(parse(text=paste("names(", .activeDataSet, ")")))
            all.names[which.variables] <- newnames
            if (length(unique(all.names)) != length(all.names)){
                errorCondition(recall=renameVariables, message="Variable names are not unique")
                return()
                }
            command <- paste("names(", .activeDataSet, ")[c(", paste(which.variables, collapse=","),
                ")] <- c(", paste('"', newnames, '"', collapse=",", sep=""), ")", sep="")
            justDoIt(command)
            logger(command)
            activeDataSet(.activeDataSet, flushModel=FALSE)
            if (.grab.focus) tkgrab.release(subdialog)
            tkfocus(.commander)
            tkdestroy(subdialog)
            }
        subOKCancelHelp()
        tkgrid(tklabel(subdialog, text="Old Name", fg="blue"), 
            tklabel(subdialog, text="New name", fg="blue"), sticky="w")
        for (i in 1:nvariables){
            valVar <- paste("newName", i, sep="")
            assign(valVar, tclVar(""))
            assign(paste("entry", i, sep=""), tkentry(subdialog, width="20", 
                textvariable=eval(parse(text=valVar))))
            tkgrid(tklabel(subdialog, text=variables[i]), eval(parse(text=paste("entry", i, sep=""))), sticky="w")
            }
        tkgrid(subButtonsFrame, sticky="w", columnspan=2)
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        dialogSuffix(subdialog, rows=nvariables+2, columns=2, focus=entry1, onOK=onOKsub)                 
        }
    OKCancelHelp(helpSubject="names")
    tkgrid(getFrame(variableBox), sticky="nw")
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix(rows=2, columns=1)
    }

setContrasts <- function(){
    if (!checkActiveDataSet()) return()
    if (!checkFactors()) return()
    initializeDialog(title="Set Contrasts for Factor")
    variableBox <- variableListBox(top, .factors, title="Factor (pick one)")
    radioButtons(name="contrasts", buttons=c("treatment", "sum", "helmert", "poly", "specify"), 
        values=c("contr.Treatment", "contr.Sum", "contr.helmert", "contr.poly", "specify"),
        labels=c("Treatment (dummy) contrasts", "Sum (deviation) contrasts", "Helmert contrasts",
            "Polynomial contrasts", "Other (specify)"), title="Contrasts")
    onOK <- function(){
        variable <- getSelection(variableBox)
        if (length(variable) == 0) {
            errorCondition(recall=setContrasts, message="You must select a variable.")
            return()
            }
        contrasts <- tclvalue(contrastsVariable)
        if (contrasts != "specify"){
            command <- paste("contrasts(", .activeDataSet, "$", variable, ') <- "', contrasts, '"', sep="")
            justDoIt(command)
            logger(command)
            activeDataSet(.activeDataSet)          
            if (.grab.focus) tkgrab.release(top)
            tkdestroy(top)
            tkfocus(.commander)
            }
        else{
            initializeDialog(subdialog, title="Specify Contrasts")
            tkgrid(tklabel(subdialog, text="Enter Contrast Coefficients", fg="blue"), sticky="w")
            env <- environment()
            tableFrame <- tkframe(subdialog)
            row.names <- eval(parse(text=paste("levels(", .activeDataSet, "$", variable, ")")))
            row.names <- substring(paste(abbreviate(row.names, 12), "            "), 1, 12)
            nrows <- length(row.names)
            ncols <- nrows - 1
            make.col.names <- "tklabel(tableFrame, text='Contrast Name:')"
            for (j in 1:ncols) {
                varname <- paste(".col.", j, sep="")
                assign(varname, tclVar(paste(".", j, sep="")), envir=env)
                make.col.names <- paste(make.col.names, ", ", 
                    "tkentry(tableFrame, width='12', textvariable=", varname, ")", sep="")
                }
            eval(parse(text=paste("tkgrid(", make.col.names, ", sticky='w')", sep="")), envir=env)
            for (i in 1:nrows){   
                make.row <- paste("tklabel(tableFrame, text='", row.names[i], "')")
                for (j in 1:ncols){
                    varname <- paste(".tab.", i, ".", j, sep="")
                    assign(varname, tclVar("0"), envir=env)
                    make.row <- paste(make.row, ", ", "tkentry(tableFrame, width='5', textvariable=", 
                        varname, ")", sep="")
                    }
                eval(parse(text=paste("tkgrid(", make.row, ", sticky='w')", sep="")), envir=env)
                }
            tkgrid(tableFrame, sticky="w")
            onOKsub <- function(){
                if (.grab.focus) tkgrab.release(top)
                tkdestroy(top)
                cell <- 0
                values <- rep(NA, nrows*ncols)
                for (j in 1:ncols){
                    for (i in 1:nrows){
                        cell <- cell + 1
                        varname <- paste(".tab.", i, ".", j, sep="")
                        values[cell] <- as.numeric(eval(parse(text=paste("tclvalue(", varname,")", sep=""))))
                        }
                    }
                values <- na.omit(values)
                if (length(values) != nrows*ncols){
                    errorCondition(subdialog, recall=setContrasts,
                        message=paste("Number of valid entries in contrast matrix(", length(values), ")\n",
                            "not equal to number of levels (", nrows,") * number of contrasts (", ncols,").", 
                            sep=""))
                    return()
                    }
                if (qr(matrix(values, nrows, ncols))$rank < ncols) {
                    errorCondition(subdialog, recall=setContrasts, message="Contrast matrix is not of full column rank")
                    return()
                    }  
                contrast.names <- rep("", ncols)
                for (j in 1:ncols){
                    varname <- paste(".col.", j, sep="")
                    contrast.names[j] <- eval(parse(text=paste("tclvalue(", varname,")", sep="")))
                    }
                if (length(unique(contrast.names)) < ncols) {
                    errorCondition(subdialog, recall=setContrasts, message="Contrast names must be unique") 
                    return()
                    }                    
                if (.grab.focus) tkgrab.release(subdialog)
                tkdestroy(subdialog)
                command <- paste("matrix(c(", paste(values, collapse=","), "), ", nrows, ", ", ncols,
                    ")", sep="")
                assign(".Contrasts", justDoIt(command), envir=.GlobalEnv)
                logger(paste(".Contrasts <- ", command, sep=""))
                command <- paste("colnames(.Contrasts) <- c(", 
                    paste("'", contrast.names, "'", sep="", collapse=", "), ")", sep="")
                justDoIt(command)
                logger(command)
                command <- paste("contrasts(", .activeDataSet, "$", variable, ") <- .Contrasts", sep="")
                justDoIt(command)
                logger(command)
                justDoIt("remove(.Contrasts, envir=.GlobalEnv)")   
                logger("remove(.Contrasts)") 
                activeDataSet(.activeDataSet, flushModel=FALSE)                                      
                tkfocus(.commander)
                }
            subOKCancelHelp(helpSubject="contrasts")
            tkgrid(tableFrame, sticky="w")
            tkgrid(tklabel(subdialog, text=""))
            tkgrid(subButtonsFrame, sticky="w")
            dialogSuffix(subdialog, rows=5, columns=1, focus=subdialog)  
            }
        }
    OKCancelHelp(helpSubject="contrasts")
    tkgrid(getFrame(variableBox), sticky="nw")
    tkgrid(contrastsFrame, sticky="w")
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix(rows=4, columns=1) 
    }
# Distributions menu dialogs

# last modified 25 June 04 by J. Fox

normalQuantiles <- function(){
    initializeDialog(title="Normal Quantiles")
    quantilesVar <- tclVar("")
    quantilesEntry <- tkentry(top, width="30", textvariable=quantilesVar)
    muVar <- tclVar("0")
    muEntry <- tkentry(top, width="6", textvariable=muVar)
    sigmaVar <- tclVar("1")
    sigmaEntry <- tkentry(top, width="6", textvariable=sigmaVar)
    tailVar <- tclVar("lower")
    lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower")
    upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper")
    onOK <- function(){
        quantiles <- gsub(" ", ",", tclvalue(quantilesVar))
        if ("" == quantiles) {
            errorCondition(recall=normalQuantiles, message="No probabilities specified.")
            return()
            }
        mu <- as.numeric(tclvalue(muVar))
        sigma <- as.numeric(tclvalue(sigmaVar))
        tail <- tclvalue(tailVar)
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        doItAndPrint(paste("qnorm(c(", quantiles, "), mean=", mu, 
            ", sd=", sigma, ", lower.tail=", tail == "lower",")", sep=""))
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="qnorm")
    tkgrid(tklabel(top, text="Probabilities"), quantilesEntry, sticky="e")
    tkgrid(tklabel(top, text="mu (mean)"), muEntry, sticky="e")
    tkgrid(tklabel(top, text="sigma (standard deviation)"), sigmaEntry, sticky="e")
    tkgrid(tklabel(top, text="Lower tail"), lowerTailButton, sticky="e")
    tkgrid(tklabel(top, text="Upper tail"), upperTailButton, sticky="e")
    tkgrid(buttonsFrame, sticky="w", columnspan=2)
    tkgrid.configure(quantilesEntry, sticky="w")
    tkgrid.configure(muEntry, sticky="w")
    tkgrid.configure(sigmaEntry, sticky="w")
    tkgrid.configure(lowerTailButton, sticky="w")
    tkgrid.configure(upperTailButton, sticky="w")
    dialogSuffix(rows=6, columns=2, focus=quantilesEntry)
    }

normalProbabilities <- function(){
    initializeDialog(title="Normal Probabilities")
    probabilitiesVar <- tclVar("")
    probabilitiesEntry <- tkentry(top, width="30", textvariable=probabilitiesVar)
    muVar <- tclVar("0")
    muEntry <- tkentry(top, width="6", textvariable=muVar)
    sigmaVar <- tclVar("1")
    sigmaEntry <- tkentry(top, width="6", textvariable=sigmaVar)
    tailVar <- tclVar("lower")
    lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower")
    upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper")
    onOK <- function(){
        probabilities <- gsub(" ", ",", tclvalue(probabilitiesVar))
        if ("" == probabilities) {
            errorCondition(recall=normalProbabilities, message="No values specified.")
            return()
            }
        mu <- as.numeric(tclvalue(muVar))
        sigma <- as.numeric(tclvalue(sigmaVar))
        tail <- tclvalue(tailVar)
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        doItAndPrint(paste("pnorm(c(", probabilities, "), mean=", mu, 
            ", sd=", sigma, ", lower.tail=", tail == "lower",")", sep=""))
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="pnorm")
    tkgrid(tklabel(top, text="Variable value(s)"), probabilitiesEntry, sticky="e")
    tkgrid(tklabel(top, text="mu (mean)"), muEntry, sticky="e")
    tkgrid(tklabel(top, text="sigma (standard deviation)"), sigmaEntry, sticky="e")
    tkgrid(tklabel(top, text="Lower tail"), lowerTailButton, sticky="e")
    tkgrid(tklabel(top, text="Upper tail"), upperTailButton, sticky="e")
    tkgrid(buttonsFrame, sticky="w", columnspan=2)
    tkgrid.configure(probabilitiesEntry, sticky="w")
    tkgrid.configure(muEntry, sticky="w")
    tkgrid.configure(sigmaEntry, sticky="w")
    tkgrid.configure(lowerTailButton, sticky="w")
    tkgrid.configure(upperTailButton, sticky="w")
    dialogSuffix(rows=6, columns=1, focus=probabilitiesEntry)
    }
    
tQuantiles <- function(){
    initializeDialog(title="t Quantiles")
    quantilesVar <- tclVar("")
    quantilesEntry <- tkentry(top, width="30", textvariable=quantilesVar)
    dfVar <- tclVar("")
    dfEntry <- tkentry(top, width="6", textvariable=dfVar)
    tailVar <- tclVar("lower")
    lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower")
    upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper")
    onOK <- function(){
        quantiles <- gsub(" ", ",", tclvalue(quantilesVar))
        if ("" == quantiles) {
            errorCondition(recall=tQuantiles, message="No probabilities specified.") 
            return()
            }
        df <- as.numeric(tclvalue(dfVar))
        if (is.na(df)) {
            errorCondition(recall=tQuantiles, message="Degrees of freedom not specified.")
            return()
            }
        tail <- tclvalue(tailVar)
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        doItAndPrint(paste("qt(c(", quantiles, "), df=", df, 
            ", lower.tail=", tail == "lower",")", sep=""))
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="qt")
    tkgrid(tklabel(top, text="Probabilities"), quantilesEntry, sticky="e")
    tkgrid(tklabel(top, text="Degrees of freedom"), dfEntry, sticky="e")
    tkgrid(tklabel(top, text="Lower tail"), lowerTailButton, sticky="e")
    tkgrid(tklabel(top, text="Upper tail"), upperTailButton, sticky="e")
    tkgrid(buttonsFrame, sticky="w", columnspan=2)
    tkgrid.configure(quantilesEntry, sticky="w")
    tkgrid.configure(dfEntry, sticky="w")
    tkgrid.configure(lowerTailButton, sticky="w")
    tkgrid.configure(upperTailButton, sticky="w")
    dialogSuffix(rows=5, columns=2, focus=quantilesEntry)
    }
    
tProbabilities <- function(){
    initializeDialog(title="t Probabilities")
    probabilitiesVar <- tclVar("")
    probabilitiesEntry <- tkentry(top, width="30", textvariable=probabilitiesVar)
    dfVar <- tclVar("")
    dfEntry <- tkentry(top, width="6", textvariable=dfVar)
    tailVar <- tclVar("lower")
    lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower")
    upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper")
    onOK <- function(){
        probabilities <- gsub(" ", ",", tclvalue(probabilitiesVar))
        df <- as.numeric(tclvalue(dfVar))
        if ("" == probabilities) {
            errorCondition(recall=tProbabilities, message="No values specified.")
            return()
            }
        df <- as.numeric(tclvalue(dfVar))
        if (is.na(df)) {
            errorCondition(recall=tProbabilities, message="Degrees of freedom not specified.")
            return()
            }
        tail <- tclvalue(tailVar)
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        doItAndPrint(paste("pt(c(", probabilities, "), df=", df, 
            ", lower.tail=", tail == "lower",")", sep=""))
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="pt")
    tkgrid(tklabel(top, text="Variable value(s)"), probabilitiesEntry, sticky="e")
    tkgrid(tklabel(top, text="Degrees of freedom"), dfEntry, sticky="e")
    tkgrid(tklabel(top, text="Lower tail"), lowerTailButton, sticky="e")
    tkgrid(tklabel(top, text="Upper tail"), upperTailButton, sticky="e")
    tkgrid(buttonsFrame, sticky="w", columnspan=2)
    tkgrid.configure(probabilitiesEntry, sticky="w")
    tkgrid.configure(dfEntry, sticky="w")
    tkgrid.configure(lowerTailButton, sticky="w")
    tkgrid.configure(upperTailButton, sticky="w")
    dialogSuffix(rows=5, columns=2, focus=probabilitiesEntry)
    }

chisqQuantiles <- function(){
    initializeDialog(title="Chi-Squared Quantiles")
    quantilesVar <- tclVar("")
    quantilesEntry <- tkentry(top, width="30", textvariable=quantilesVar)
    dfVar <- tclVar("")
    dfEntry <- tkentry(top, width="6", textvariable=dfVar)
    tailVar <- tclVar("lower")
    lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower")
    upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper")
    onOK <- function(){
        quantiles <- gsub(" ", ",", tclvalue(quantilesVar))
        if ("" == quantiles) {
            errorCondition(recall=chisqQuantiles, message="No probabilities specified.")
            return()
            }
        df <- as.numeric(tclvalue(dfVar))
        if (is.na(df)) {
            errorCondition(recall=chisqQuantiles, message="Degrees of freedom not specified.")
            return()
            }
        tail <- tclvalue(tailVar)
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        doItAndPrint(paste("qchisq(c(", quantiles, "), df=", df, 
            ", lower.tail=", tail == "lower",")", sep=""))
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="qchisq")
    tkgrid(tklabel(top, text="Probabilities"), quantilesEntry, sticky="e")
    tkgrid(tklabel(top, text="Degrees of freedom"), dfEntry, sticky="e")
    tkgrid(tklabel(top, text="Lower tail"), lowerTailButton, sticky="e")
    tkgrid(tklabel(top, text="Upper tail"), upperTailButton, sticky="e")
    tkgrid(buttonsFrame, columnspan=2, sticky="w")
    tkgrid.configure(quantilesEntry, sticky="w")
    tkgrid.configure(dfEntry, sticky="w")
    tkgrid.configure(lowerTailButton, sticky="w")
    tkgrid.configure(upperTailButton, sticky="w")
    dialogSuffix(rows=5, columns=2, focus=quantilesEntry)
    }
    
chisqProbabilities <- function(){
    initializeDialog(title="Chi-Squared Probabilities")
    probabilitiesVar <- tclVar("")
    probabilitiesEntry <- tkentry(top, width="30", textvariable=probabilitiesVar)
    dfVar <- tclVar("")
    dfEntry <- tkentry(top, width="6", textvariable=dfVar)
    tailVar <- tclVar("lower")
    lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower")
    upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper")
    onOK <- function(){
        probabilities <- gsub(" ", ",", tclvalue(probabilitiesVar))
        if ("" == probabilities) {
            errorCondition(recall=chisqProbabilities, message="No values specified.")
            return()
            }
        df <- as.numeric(tclvalue(dfVar))
        if (is.na(df)) {
            errorCondition(recall=chisqProbabilities, message="Degrees of freedom not specified.")
            return()
            }
        tail <- tclvalue(tailVar)
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        doItAndPrint(paste("pchisq(c(", probabilities, "), df=", df, 
            ", lower.tail=", tail == "lower",")", sep=""))
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="pchisq")
    tkgrid(tklabel(top, text="Variable value(s)"), probabilitiesEntry, sticky="e")
    tkgrid(tklabel(top, text="Degrees of freedom"), dfEntry, sticky="e")
    tkgrid(tklabel(top, text="Lower tail"), lowerTailButton, sticky="e")
    tkgrid(tklabel(top, text="Upper tail"), upperTailButton, sticky="e")
    tkgrid(OKbutton, cancelButton, sticky="w")
    tkgrid(buttonsFrame, columnspan=2, sticky="w")
    tkgrid.configure(probabilitiesEntry, sticky="w")
    tkgrid.configure(dfEntry, sticky="w")
    tkgrid.configure(lowerTailButton, sticky="w")
    tkgrid.configure(upperTailButton, sticky="w")
    dialogSuffix(rows=5, columns=2, focus=probabilitiesEntry)
    }

FQuantiles <- function(){
    initializeDialog(title="F Quantiles")
    quantilesVar <- tclVar("")
    quantilesEntry <- tkentry(top, width="30", textvariable=quantilesVar)
    df1Var <- tclVar("")
    df1Entry <- tkentry(top, width="6", textvariable=df1Var)
    df2Var <- tclVar("")
    df2Entry <- tkentry(top, width="6", textvariable=df2Var)
    tailVar <- tclVar("lower")
    lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower")
    upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper")
    onOK <- function(){
        quantiles <- gsub(" ", ",", tclvalue(quantilesVar))
        if ("" == quantiles) {
            errorCondition(recall=FQuantiles, message="Probabilities not specified")
            return()
            }
        df1 <- as.numeric(tclvalue(df1Var))
        df2 <- as.numeric(tclvalue(df2Var))
        if (is.na(df1) || is.na(df2)) {
            errorCondition(recall=FQuantiles, message="Degrees of freedom not specified.")
            return()
            }
        tail <- tclvalue(tailVar)
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        doItAndPrint(paste("qf(c(", quantiles, "), df1=", df1, 
            ", df2=", df2, ", lower.tail=", tail == "lower",")", sep=""))
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="qf")
    tkgrid(tklabel(top, text="Probabilities"), quantilesEntry, sticky="e")
    tkgrid(tklabel(top, text="Numerator degrees of freedom"), df1Entry, sticky="e")
    tkgrid(tklabel(top, text="Denominator degrees of freedom"), df2Entry, sticky="e")
    tkgrid(tklabel(top, text="Lower tail"), lowerTailButton, sticky="e")
    tkgrid(tklabel(top, text="Upper tail"), upperTailButton, sticky="e")
    tkgrid(buttonsFrame, columnspan=2, sticky="w")
    tkgrid.configure(quantilesEntry, sticky="w")
    tkgrid.configure(df1Entry, sticky="w")
    tkgrid.configure(df2Entry, sticky="w")
    tkgrid.configure(lowerTailButton, sticky="w")
    tkgrid.configure(upperTailButton, sticky="w")
    dialogSuffix(rows=6, columns=2, focus=quantilesEntry)
    }
    
FProbabilities <- function(){
    initializeDialog(title="F Probabilities")
    probabilitiesVar <- tclVar("")
    probabilitiesEntry <- tkentry(top, width="30", textvariable=probabilitiesVar)
    df1Var <- tclVar("")
    df1Entry <- tkentry(top, width="6", textvariable=df1Var)
    df2Var <- tclVar("")
    df2Entry <- tkentry(top, width="6", textvariable=df2Var)
    tailVar <- tclVar("lower")
    lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower")
    upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper")
    onOK <- function(){
        probabilities <- gsub(" ", ",", tclvalue(probabilitiesVar))
        if ("" == probabilities) {
            errorCondition(recall=FProbabilities, message="Values not specified.")
            return()
            }
        df1 <- as.numeric(tclvalue(df1Var))
        df2 <- as.numeric(tclvalue(df2Var))
        if (is.na(df1) || is.na(df2)) {
            errorCondition(recall=FProbabilities, message="Degrees of freedom not specified.")
            return()
            }
        tail <- tclvalue(tailVar)
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        doItAndPrint(paste("pf(c(", probabilities, "), df1=", df1, 
            ", df2=", df2, ", lower.tail=", tail == "lower",")", sep=""))
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="pf")
    tkgrid(tklabel(top, text="Variable value(s)"), probabilitiesEntry, sticky="e")
    tkgrid(tklabel(top, text="Numerator degrees of freedom"), df1Entry, sticky="e")
    tkgrid(tklabel(top, text="Denominator degrees of freedom"), df2Entry, sticky="e")    
    tkgrid(tklabel(top, text="Lower tail"), lowerTailButton, sticky="e")
    tkgrid(tklabel(top, text="Upper tail"), upperTailButton, sticky="e")
    tkgrid(buttonsFrame, columnspan=2, sticky="w")
    tkgrid.configure(probabilitiesEntry, sticky="w")
    tkgrid.configure(df1Entry, sticky="w")
    tkgrid.configure(df2Entry, sticky="w")
    tkgrid.configure(lowerTailButton, sticky="w")
    tkgrid.configure(upperTailButton, sticky="w")
    dialogSuffix(rows=6, columns=2, focus=probabilitiesEntry)
    }

binomialQuantiles <- function(){
    initializeDialog(title="Binomial Quantiles")
    quantilesVar <- tclVar("")
    quantilesEntry <- tkentry(top, width="30", textvariable=quantilesVar)
    trialsVar <- tclVar("")
    trialsEntry <- tkentry(top, width="6", textvariable=trialsVar)
    probVar <- tclVar(".5")
    probEntry <- tkentry(top, width="6", textvariable=probVar)
    tailVar <- tclVar("lower")
    lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower")
    upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper")
    onOK <- function(){
        quantiles <- gsub(" ", ",", tclvalue(quantilesVar))
        trials <- as.numeric(tclvalue(trialsVar))
        prob <- as.numeric(tclvalue(probVar))
        if ("" == quantiles) {
            errorCondition(recall=binomialQuantiles, message="Probabilities not specified.")
            return()
            }
        if (is.na(trials)) {
            errorCondition(recall=binomialQuantiles, message="Binomial trials not specified.")
            return()
            }
        if (is.na(prob)) {
            errorCondition(recall=binomialQuantiles, message="Probability of success not specified.")
            return()
            }
        tail <- tclvalue(tailVar)
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        doItAndPrint(paste("qbinom(c(", quantiles, "), size=", trials, 
            ", prob=", prob, ", lower.tail=", tail == "lower",")", sep=""))
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="qbinom")
    tkgrid(tklabel(top, text="Probabilities"), quantilesEntry, sticky="e")
    tkgrid(tklabel(top, text="Binomial trials"), trialsEntry, sticky="e")
    tkgrid(tklabel(top, text="Probability of success"), probEntry, sticky="e")
    tkgrid(tklabel(top, text="Lower tail"), lowerTailButton, sticky="e")
    tkgrid(tklabel(top, text="Upper tail"), upperTailButton, sticky="e")
    tkgrid(buttonsFrame,columnspan=2, sticky="w")
    tkgrid.configure(quantilesEntry, sticky="w")
    tkgrid.configure(trialsEntry, sticky="w")
    tkgrid.configure(probEntry, sticky="w")
    tkgrid.configure(lowerTailButton, sticky="w")
    tkgrid.configure(upperTailButton, sticky="w")
    dialogSuffix(rows=6, columns=2, focus=quantilesEntry)
    }
    
binomialProbabilities <- function(){
    initializeDialog(title="Cumulative Binomial Probabilities")
    probabilitiesVar <- tclVar("")
    probabilitiesEntry <- tkentry(top, width="30", textvariable=probabilitiesVar)
    trialsVar <- tclVar("")
    trialsEntry <- tkentry(top, width="6", textvariable=trialsVar)
    probVar <- tclVar(".5")
    probEntry <- tkentry(top, width="6", textvariable=probVar)
    tailVar <- tclVar("lower")
    lowerTailButton <- tkradiobutton(top, variable=tailVar, value="lower")
    upperTailButton <- tkradiobutton(top, variable=tailVar, value="upper")
    onOK <- function(){
        probabilities <- gsub(" ", ",", tclvalue(probabilitiesVar))
        trials <- as.numeric(tclvalue(trialsVar))
        prob <- as.numeric(tclvalue(probVar))
        if ("" == probabilities) {
            errorCondition(recall=binomialProbabilities, message="Values not specified.") 
            return()
            }
        if (is.na(trials)) {
            errorCondition(recall=binomialProbabilities, message="Binomial trials not specified.")
            return()
            }
        if (is.na(prob)) {
            errorCondition(recall=binomialProbabilities, message="Probability of success not specified.")
            return()
            }
        tail <- tclvalue(tailVar)
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        doItAndPrint(paste("pbinom(c(", probabilities, "), size=", trials, 
            ", prob=", prob, ", lower.tail=", tail == "lower",")", sep=""))
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="pbinom")
    tkgrid(tklabel(top, text="Variable value(s)"), probabilitiesEntry, sticky="e")
    tkgrid(tklabel(top, text="Binomial trials"), trialsEntry, sticky="e")
    tkgrid(tklabel(top, text="Probability of success"), probEntry, sticky="e")    
    tkgrid(tklabel(top, text="Lower tail"), lowerTailButton, sticky="e")
    tkgrid(tklabel(top, text="Upper tail"), upperTailButton, sticky="e")
    tkgrid(buttonsFrame, columnspan=2, sticky="w")
    tkgrid.configure(probabilitiesEntry, sticky="w")
    tkgrid.configure(trialsEntry, sticky="w")
    tkgrid.configure(probEntry, sticky="w")
    tkgrid.configure(lowerTailButton, sticky="w")
    tkgrid.configure(upperTailButton, sticky="w")
    dialogSuffix(rows=6, columns=2, focus=probabilitiesEntry)
    }

binomialMass <- function(){
    checkTrials <- function(trials){
        tkmessageBox(message=paste("Number of trials", trials, "is large.\nCreate long output?"),
            icon="warning", type="yesno", default="no")
        }
    initializeDialog(title="Binomial Probabilities")
    trialsVar <- tclVar("")
    trialsEntry <- tkentry(top, width="6", textvariable=trialsVar)
    probVar <- tclVar(".5")
    probEntry <- tkentry(top, width="6", textvariable=probVar)
    onOK <- function(){
        trials <- as.numeric(tclvalue(trialsVar))
        if (is.na(trials)) {
            errorCondition(recall=binomialMass, message="Binomial trials not specified.")
            return()
            }
        if (trials > 50){
            if ("no" == tclvalue(checkTrials(trials))){
                if (.grab.focus) tkgrab.release(top)
                tkdestroy(top)
                binomialMass()
                return()
                }
            }
        prob <- as.numeric(tclvalue(probVar))
        if (is.na(prob)) {
            errorCondition(recall=binomialMass, message="Probability of success not specified.")
            return()
            }
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        command <- paste("data.frame(Pr=dbinom(0:", trials, ", size=", trials, 
            ", prob=", prob, "))", sep="")
        logger(paste(".Table <- ", command, sep=""))
        assign(".Table", justDoIt(command), envir=.GlobalEnv)
        logger(paste("rownames(.Table) <- 0:", trials, sep=""))
        justDoIt(paste("rownames(.Table) <- 0:", trials, sep=""))
        doItAndPrint(".Table")
        logger("remove(.Table)") 
        remove(.Table, envir=.GlobalEnv)       
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="dbinom")
    tkgrid(tklabel(top, text="Binomial trials"), trialsEntry, sticky="e")
    tkgrid(tklabel(top, text="Probability of success"), probEntry, sticky="e")
    tkgrid(buttonsFrame, columnspan=2, sticky="w")
    tkgrid.configure(trialsEntry, sticky="w")
    tkgrid.configure(probEntry, sticky="w")
    dialogSuffix(rows=3, columns=2, focus=trialsEntry)
    }

PoissonMass <- function(){
    checkRange <- function(range){
        tkmessageBox(message=paste("Range of values over which to plot,", range, ", is large.\nCreate long output?"),
            icon="warning", type="yesno", default="no")
        }
    initializeDialog(title="Poisson Probabilities")
    meanVar <- tclVar("")
    meanEntry <- tkentry(top, width="6", textvariable=meanVar)
    onOK <- function(){
        mean <- as.numeric(tclvalue(meanVar))
        if (is.na(mean)) {
            errorCondition(recall=PoissonMass, message="Poisson mean not specified.")
            return()
            }
        min <- qpois(.00005, lambda=mean)
        max <- qpois(.99995, lambda=mean)
        range <- max - min
        if (range > 50){
            if ("no" == tclvalue(checkRange(range))){
                if (.grab.focus) tkgrab.release(top)
                tkdestroy(top)
                PoissonMass()
                return()
                }
            }
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        command <- paste("data.frame(Pr=round(dpois(", min, ":", max, ", lambda=", mean, "), 4))", sep="")
        logger(paste(".Table <- ", command, sep=""))
        assign(".Table", justDoIt(command), envir=.GlobalEnv)
        logger(paste("rownames(.Table) <- ", min, ":", max, sep=""))
        justDoIt(paste("rownames(.Table) <- ", min, ":", max, sep=""))
        doItAndPrint(".Table")
        logger("remove(.Table)") 
        remove(.Table, envir=.GlobalEnv)       
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="dpois")
    tkgrid(tklabel(top, text="Mean"), meanEntry, sticky="e")
    tkgrid(buttonsFrame, columnspan=2, sticky="w")
    tkgrid.configure(meanEntry, sticky="w")
    dialogSuffix(rows=2, columns=2, focus=meanEntry)
    }
# Distributions  -> Plot Distributions menu dialogs

# last modified 25 June 04 by J. Fox

normalDistributionPlot <- function(){
    initializeDialog(title="Normal Distribution")
    muVar <- tclVar("0")
    muEntry <- tkentry(top, width="6", textvariable=muVar)
    sigmaVar <- tclVar("1")
    sigmaEntry <- tkentry(top, width="6", textvariable=sigmaVar)
    functionVar <- tclVar("Density")
    densityButton <- tkradiobutton(top, variable=functionVar, value="Density")
    distributionButton <- tkradiobutton(top, variable=functionVar, value="Cumulative Probability")
    onOK <- function(){
        mu <- as.numeric(tclvalue(muVar))
        sigma <- as.numeric(tclvalue(sigmaVar))
        fun <- tclvalue(functionVar)
        fn <- if (fun == "Density") "dnorm" else "pnorm"
        min <- round(qnorm(.0005, mean=mu, sd=sigma), 3)
        max <- round(qnorm(.9995, mean=mu, sd=sigma), 3)
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        command <- paste("seq(", min, ", ", max, ", length=100)", sep="")
        logger(paste(".x <- ", command, sep=""))
        assign(".x", justDoIt(command), envir=.GlobalEnv)
        doItAndPrint(paste("plot(.x, ", fn, "(.x, mean=", mu, 
            ", sd=", sigma, '), xlab="x", ylab="', fun, 
            '", main=expression(paste("Normal Distribution: ", mu, " = ',
            mu, ', ", sigma, " = ', sigma, '")), type="l")', sep=""))
        doItAndPrint('abline(h=0, col="gray")')
        remove(.x, envir=.GlobalEnv)
        logger("remove(.x)")
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="dnorm")
    tkgrid(tklabel(top, text="mu (mean)"), muEntry, sticky="e")
    tkgrid(tklabel(top, text="sigma (standard deviation)"), sigmaEntry, sticky="e")
    tkgrid(tklabel(top, text="Plot density function"), densityButton, sticky="e")
    tkgrid(tklabel(top, text="Plot distribution function"), distributionButton, sticky="e")
    tkgrid(buttonsFrame, columnspan=2, sticky="w")
    tkgrid.configure(muEntry, sticky="w")
    tkgrid.configure(sigmaEntry, sticky="w")
    tkgrid.configure(densityButton, sticky="w")
    tkgrid.configure(distributionButton, sticky="w")
    dialogSuffix(rows=5, columns=2, focus=muEntry)
    }

tDistributionPlot <- function(){
    initializeDialog(title="t Distribution")
    dfVar <- tclVar("")
    dfEntry <- tkentry(top, width="6", textvariable=dfVar)
    functionVar <- tclVar("Density")
    densityButton <- tkradiobutton(top, variable=functionVar, value="Density")
    distributionButton <- tkradiobutton(top, variable=functionVar, value="Cumulative Probability")
    onOK <- function(){
        df <- as.numeric(tclvalue(dfVar))
        if (is.na(df)) {
            errorCondition(recall=tDistributionPlot, message="Degrees of freedom not specified.")
            return()
            }
        fun <- tclvalue(functionVar)
        fn <- if (fun == "Density") "dt" else "pt"
        min <- round(qt(.0005, df=df), 3)
        max <- round(qt(.9995, df=df), 3)
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        command <- paste("seq(", min, ", ", max, ", length=100)", sep="")
        logger(paste(".x <- ", command, sep=""))
        assign(".x", justDoIt(command), envir=.GlobalEnv)
        doItAndPrint(paste("plot(.x, ", fn, "(.x, df=", df, 
            '), xlab="t", ylab="', fun, 
            '", main="t Distribution: df = ', df, '", type="l")', sep=""))
        doItAndPrint('abline(h=0, col="gray")')
        remove(.x, envir=.GlobalEnv)
        logger("remove(.x)")
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="dt")
    tkgrid(tklabel(top, text="Degrees of freedom"), dfEntry, sticky="e")
    tkgrid(tklabel(top, text="Plot density function"), densityButton, sticky="e")
    tkgrid(tklabel(top, text="Plot distribution function"), distributionButton, sticky="e")
    tkgrid(buttonsFrame, columnspan=2, sticky="w")
    tkgrid.configure(dfEntry, sticky="w")
    tkgrid.configure(densityButton, sticky="w")
    tkgrid.configure(distributionButton, sticky="w")
    dialogSuffix(rows=4, columns=2, focus=dfEntry)
    }

chisquareDistributionPlot <- function(){
    initializeDialog(title="Chi-squared Distribution")
    dfVar <- tclVar("")
    dfEntry <- tkentry(top, width="6", textvariable=dfVar)
    functionVar <- tclVar("Density")
    densityButton <- tkradiobutton(top, variable=functionVar, value="Density")
    distributionButton <- tkradiobutton(top, variable=functionVar, value="Cumulative Probability")
    onOK <- function(){
        df <- as.numeric(tclvalue(dfVar))
        if (is.na(df)) {
            errorCondition(recall=chisquareDistributionPlot,message="Degrees of freedom not specified.")
            return()
            }
        fun <- tclvalue(functionVar)
        fn <- if (fun == "Density") "dchisq" else "pchisq"
        min <- round(qchisq(.0005, df=df), 3)
        max <- round(qchisq(.9995, df=df), 3)
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        command <- paste("seq(", min, ", ", max, ", length=100)", sep="")
        logger(paste(".x <- ", command, sep=""))
        assign(".x", justDoIt(command), envir=.GlobalEnv)
        doItAndPrint(paste("plot(.x, ", fn, "(.x, df=", df, 
            '), xlab=expression(chi^2), ylab="', fun, 
            '", main="Chi-Squared Distribution: df = ', df, '", type="l")', sep=""))
        doItAndPrint('abline(h=0, col="gray")')
        remove(.x, envir=.GlobalEnv)
        logger("remove(.x)")
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="dchisq")
    tkgrid(tklabel(top, text="Degrees of freedom"), dfEntry, sticky="e")
    tkgrid(tklabel(top, text="Plot density function"), densityButton, sticky="e")
    tkgrid(tklabel(top, text="Plot distribution function"), distributionButton, sticky="e")
    tkgrid(buttonsFrame, columnspan=2, sticky="w")
    tkgrid.configure(dfEntry, sticky="w")
    tkgrid.configure(densityButton, sticky="w")
    tkgrid.configure(distributionButton, sticky="w")
    dialogSuffix(rows=4, columns=2, focus=dfEntry)
    }

FDistributionPlot <- function(){
    initializeDialog(title="F Distribution")
    df1Var <- tclVar("")
    df2Var <- tclVar("")
    df1Entry <- tkentry(top, width="6", textvariable=df1Var)
    df2Entry <- tkentry(top, width="6", textvariable=df2Var)
    functionVar <- tclVar("Density")
    densityButton <- tkradiobutton(top, variable=functionVar, value="Density")
    distributionButton <- tkradiobutton(top, variable=functionVar, value="Cumulative Probability")
    onOK <- function(){
        df1 <- as.numeric(tclvalue(df1Var))
        df2 <- as.numeric(tclvalue(df2Var))
        if (is.na(df1)) {
            errorCondition(recall=FDistributionPlot, message="Numerator degrees of freedom not specified.")
            return()
            }
        if (is.na(df2)) {
             errorCondition(recall=FDistributionPlot, message="Denominator degrees of freedom not specified.")
            return()
            }
        fun <- tclvalue(functionVar)
        fn <- if (fun == "Density") "df" else "pf"
        min <- round(qf(.0005, df1=df1, df2=df2), 3)
        max <- round(qf(.9995, df1=df1, df2=df2), 3)
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        command <- paste("seq(", min, ", ", max, ", length=100)", sep="")
        logger(paste(".x <- ", command, sep=""))
        assign(".x", justDoIt(command), envir=.GlobalEnv)
        doItAndPrint(paste("plot(.x, ", fn, "(.x, df1=", df1, ", df2=", df2,
            '), xlab="f", ylab="', fun, 
            '", main="F Distribution: Numerator df = ', df1, ', Denominator df = ', df2, 
            '", type="l")', sep=""))
        doItAndPrint('abline(h=0, col="gray")')
        remove(.x, envir=.GlobalEnv)
        logger("remove(.x)")
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="df")
    tkgrid(tklabel(top, text="Numerator degrees of freedom"), df1Entry, sticky="e")
    tkgrid(tklabel(top, text="Denominator degrees of freedom"), df2Entry, sticky="e")
    tkgrid(tklabel(top, text="Plot density function"), densityButton, sticky="e")
    tkgrid(tklabel(top, text="Plot distribution function"), distributionButton, sticky="e")
    tkgrid(buttonsFrame, columnspan=2, sticky="w")
    tkgrid.configure(df1Entry, sticky="w")
    tkgrid.configure(df2Entry, sticky="w")
    tkgrid.configure(densityButton, sticky="w")
    tkgrid.configure(distributionButton, sticky="w")
    dialogSuffix(rows=5, columns=2, focus=df1Entry)
    }

binomialDistributionPlot <- function(){
    initializeDialog(title="Binomial Distribution")
    trialsVar <- tclVar("")
    trialsEntry <- tkentry(top, width="6", textvariable=trialsVar)
    probVar <- tclVar(".5")
    probEntry <- tkentry(top, width="6", textvariable=probVar)
    functionVar <- tclVar("Probability")
    densityButton <- tkradiobutton(top, variable=functionVar, value="Probability")
    distributionButton <- tkradiobutton(top, variable=functionVar, value="Cumulative Probability")
    onOK <- function(){
        trials <- as.numeric(tclvalue(trialsVar))
        if (is.na(trials)) {
            errorCondition(recall=binomialDistributionPlot, message="Binomial trials not specified.")
            return()
            }
        prob <- as.numeric(tclvalue(probVar))
        if (is.na(prob)) {
            errorCondition(recall=binomialDistributionPlot, message="Probability of success not specified.")
            return()
            }
        fun <- tclvalue(functionVar)
        min <- qbinom(.0005, size=trials, prob=prob)
        max <- qbinom(.9995, size=trials, prob=prob)
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        command <- paste(min, ":", max, sep="")
        logger(paste(".x <- ", command, sep=""))
        assign(".x", justDoIt(command), envir=.GlobalEnv)
        if (fun == "Probability"){
            doItAndPrint(paste("plot(.x, dbinom(.x, size=", trials, ", prob=", prob,
                '), xlab="Number of Successes", ylab="Probability Mass", main="Binomial Distribution: Trials = ', 
                trials, ', Probability of success = ', prob, '", type="h")', sep=""))
            doItAndPrint(paste("points(.x, dbinom(.x, size=", trials, ", prob=", prob,
                '), pch=16)', sep=""))
            }
        else {
            command <- "rep(.x, rep(2, length(.x)))"
            logger(paste(".x <- ", command, sep=""))
            assign(".x", justDoIt(command), envir=.GlobalEnv)
            doItAndPrint(paste("plot(.x[-1], pbinom(.x, size=", trials, ", prob=", prob,
                ')[-length(.x)], xlab="Number of Successes", ylab="Cumulative Probability", main="Binomial Distribution: Trials = ', 
                trials, ', Probability of success = ', prob, '", type="l")', sep=""))
            }
        doItAndPrint('abline(h=0, col="gray")')
        remove(.x, envir=.GlobalEnv)
        logger("remove(.x)")
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="dbinom")
    tkgrid(tklabel(top, text="Binomial trials"), trialsEntry, sticky="e")
    tkgrid(tklabel(top, text="Probability of success"), probEntry, sticky="e")
    tkgrid(tklabel(top, text="Plot probability mass function"), densityButton, sticky="e")
    tkgrid(tklabel(top, text="Plot distribution function"), distributionButton, sticky="e")
    tkgrid(buttonsFrame, columnspan=2, sticky="w")
    tkgrid.configure(trialsEntry, sticky="w")
    tkgrid.configure(probEntry, sticky="w")
    tkgrid.configure(densityButton, sticky="w")
    tkgrid.configure(distributionButton, sticky="w")
    dialogSuffix(rows=5, columns=2, focus=trialsEntry)
    }

PoissonDistributionPlot <- function(){
    initializeDialog(title="Poisson Distribution")
    meanVar <- tclVar("")
    meanEntry <- tkentry(top, width="6", textvariable=meanVar)
    functionVar <- tclVar("Probability")
    densityButton <- tkradiobutton(top, variable=functionVar, value="Probability")
    distributionButton <- tkradiobutton(top, variable=functionVar, value="Cumulative Probability")
    onOK <- function(){
        mean <- as.numeric(tclvalue(meanVar))
        if (is.na(mean)) {
            errorCondition(recall=PoissonDistributionPlot, message="Mean not specified.")
            return()
            }
        fun <- tclvalue(functionVar)
        min <- qpois(.0005, lambda=mean)
        max <- qpois(.9995, lambda=mean)
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        command <- paste(min, ":", max, sep="")
        logger(paste(".x <- ", command, sep=""))
        assign(".x", justDoIt(command), envir=.GlobalEnv)
        if (fun == "Probability"){
            doItAndPrint(paste("plot(.x, dpois(.x, lambda=", mean,
                '), xlab="x", ylab="Probability Mass", main="Poisson Distribution: Mean = ', 
                mean, '", type="h")', sep=""))
            doItAndPrint(paste("points(.x, dpois(.x, lambda=", mean,
                '), pch=16)', sep=""))
            }
        else {
            command <- "rep(.x, rep(2, length(.x)))"
            logger(paste(".x <- ", command, sep=""))
            assign(".x", justDoIt(command), envir=.GlobalEnv)
            doItAndPrint(paste("plot(.x[-1], ppois(.x, lambda=", mean,
                ')[-length(.x)], xlab="x", ylab="Probability Mass", main="Poisson Distribution: Mean = ', 
                mean, '", type="l")', sep=""))
            }
        doItAndPrint('abline(h=0, col="gray")')
        remove(.x, envir=.GlobalEnv)
        logger("remove(.x)")
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="dpois")
    tkgrid(tklabel(top, text="mean"), meanEntry, sticky="e")
    tkgrid(tklabel(top, text="Plot probability mass function"), densityButton, sticky="e")
    tkgrid(tklabel(top, text="Plot distribution function"), distributionButton, sticky="e")
    tkgrid(buttonsFrame, columnspan=2, sticky="w")
    tkgrid.configure(meanEntry, sticky="w")
    tkgrid.configure(densityButton, sticky="w")
    tkgrid.configure(distributionButton, sticky="w")
    dialogSuffix(rows=4, columns=2, focus=meanEntry)
    }
# last modified 15 Jan 2005 by J. Fox

# File menu dialogs

loadLog <- function(){
    logFile <- tclvalue(tkgetOpenFile(filetypes='{"Script Files" {".R"}} {"All Files" {"*"}}',
        defaultextension="log"))
    if (logFile == "") return()
    fileCon <- file(logFile, "r")
    contents <- readLines(fileCon)
    close(fileCon)
    assign(".logFileName", logFile, envir=.GlobalEnv)
    if (tclvalue(tkget(.log, "1.0", "end")) != "\n"){
        response2 <- tkmessageBox(message="Save current log file?",
                icon="question", type="yesno", default="yes")
        if ("yes" == tclvalue(response2)) saveLog()
        }
    tkdelete(.log, "1.0", "end")
    tkinsert(.log, "end", paste(contents, collapse="\n"))
    }
    
saveLog <- function() {
    if (is.null(.logFileName)) {
        saveLogAs()
        return()
        }
    log <- tclvalue(tkget(.log, "1.0", "end"))
    fileCon <- file(.logFileName, "w")
    cat(log, file = fileCon)
    close(fileCon)
    }

saveLogAs <- function() {
    logFile <- tclvalue(tkgetSaveFile(filetypes='{"Script Files" {".R"}} {"All Files" {"*"}}',
        defaultextension="R", initialfile="RCommander.R"))
    log <- tclvalue(tkget(.log, "1.0", "end"))
    fileCon <- file(logFile, "w")
    cat(log, file = fileCon)
    close(fileCon)
    assign(".logFileName", logFile, envir=.GlobalEnv)
    }

saveOutput <- function() {
    if (is.null(.outputFileName)) {
        saveOutputAs()
        return()
        }
    output <- tclvalue(tkget(.output, "1.0", "end"))
    fileCon <- file(.outputFileName, "w")
    cat(output, file = fileCon)
    close(fileCon)
    }

saveOutputAs <- function() {
    outputFile <- tclvalue(tkgetSaveFile(filetypes='{"Output Files" {".txt"}} {"All Files" {"*"}}',
        defaultextension="txt", initialfile="RCommander.txt"))
    output <- tclvalue(tkget(.output, "1.0", "end"))
    fileCon <- file(outputFile, "w")
    cat(output, file = fileCon)
    close(fileCon)
    assign(".outputFileName", outputFile, envir=.GlobalEnv)
    }

saveWorkspaceAs <- function(){
    saveFile <- tclvalue(tkgetSaveFile(filetypes='{"All Files" {"*"}}',
        defaultextension="", initialfile=".RData"))
    if (saveFile == "") return()
    save(list=ls(envir=.GlobalEnv), file=saveFile)
    assign(".saveFileName", saveFile, envir=.GlobalEnv)
    }

saveWorkspace <- function() {
    if (is.null(.saveFileName)) saveWorkspaceAs()
    else save(list=ls(envir=.GlobalEnv), file=.saveFileName)
    }
    
closeCommander <- function(){
    globals <- c(".activeDataSet", ".activeModel", ".attach.data.set", ".command.text.color", ".commander", ".grab.focus", 
        ".console.output", ".contrasts", ".dataSetLabel", ".dataSetName", ".double.click", ".factors",
        ".length.messages", ".log", ".log.commands", ".logFileName", ".logFont", ".log.font.size", ".log.text.color",
        ".modelClasses", ".modelLabel", ".modelName", ".modelNumber", ".modelWithSubset", ".multiple.select.mode",
        ".numeric", "oldPager", ".operatorFont", ".output", ".output.text.color", ".outputFileName", 
        ".report.X11.warnings", ".rgl", ".rglPackage", ".saveFileName", ".saveOptions", ".showData.threshold", ".sort.names",
        ".twoLevelFactors", ".variables")
    response <- tclvalue(tkmessageBox(message="Exit?",
        icon="question", type="okcancel", default="cancel"))
    if (response == "cancel") return(invisible(response))
    sink(type="message")
    if (.rgl) rgl.quit()
    if (!is.null(.activeDataSet) && .attach.data.set) 
        justDoIt(logger(paste("detach(", .activeDataSet, ")", sep="")))
    assign(".activeDataSet", NULL, envir=.GlobalEnv)
    assign(".activeModel", NULL, envir=.GlobalEnv)
    if (.log.commands && tclvalue(tkget(.log, "1.0", "end")) != "\n"){
        response2 <- tkmessageBox(message="Save script file?",
                icon="question", type="yesno", default="yes")
        if ("yes" == tclvalue(response2)) saveLog()
        }
    if (!.console.output && tclvalue(tkget(.output, "1.0", "end")) != "\n"){
        response3 <- tkmessageBox(message="Save output file?",
                icon="question", type="yesno", default="yes")
        if ("yes" == tclvalue(response3)) saveOutput()
        }
    if (.Platform$OS.type != "windows") options(.oldPager)
    options(.saveOptions)
    tkdestroy(.commander)
    tkwait <- options("Rcmdr")[[1]]$tkwait  # to address problem in Debian Linux
    if ((!is.null(tkwait)) && tkwait) tclvalue(.commander.done) <<- "1"   
    which.globals <- sapply(globals, exists, envir=.GlobalEnv)
    remove(list=globals[which.globals], envir=.GlobalEnv)
    return(invisible(response))
    }
    
closeCommanderAndR <- function(){
    response <- closeCommander()
    if (response == "cancel") return()
    quit(save="no")
    }

Options <- function(){
    setOption <- function(option, default) {
        if (is.null(current[[option]])) default else current[[option]]
        }
    initializeDialog(title="Commander Options")
    current <- options("Rcmdr")[[1]]
    console.output <- setOption("console.output", FALSE)
    log.commands <- setOption("log.commands", TRUE)
    log.font.size <- setOption("log.font.size", 10)
    log.width <- setOption("log.width", 80)
    log.height <- if (!is.null(current$log.height)) current$log.height
                    else if (!log.commands) 0 else 10
    output.height <- if (!is.null(current$output.height)) current$output.height
        else if (console.output) 0 else 2*log.height 
    contrasts <- setOption("contrasts", c("contr.Treatment", "contr.poly"))
    grab.focus <- setOption("grab.focus", TRUE)
    double.click <- setOption("double.click", FALSE)
    sort.names <- setOption("sort.names", TRUE)
    show.edit.button <- setOption("show.edit.button", TRUE)
    scale.factor <- current$scale.factor
    default.font.size <- setOption("default.font.size", 10)
    default.font <- setOption("default.font", 
        paste("*helvetica-medium-r-normal-*-", default.font.size, "*", sep=""))
    consoleOutputVar <- tclVar(console.output)
    consoleOutputCheckBox <- tkcheckbutton(top, variable=consoleOutputVar)
    logCommandsVar <- tclVar(log.commands)
    logCommandsCheckBox <- tkcheckbutton(top, variable=logCommandsVar)
    logFontSizeVar <- tclVar(log.font.size)
    logFontSizeSlider <- tkscale(top, from=6, to=20, showvalue=TRUE, variable=logFontSizeVar,
        resolution=1, orient="horizontal")
    logWidthVar <- tclVar(log.width)
    logWidthSlider <- tkscale(top, from=30, to=120, showvalue=TRUE, variable=logWidthVar,
        resolution=5, orient="horizontal")    
    logHeightVar <- tclVar(log.height)
    logHeightSlider <- tkscale(top, from=0, to=25, showvalue=TRUE, variable=logHeightVar,
        resolution=1, orient="horizontal")   
    outputHeightVar <- tclVar(output.height)
    outputHeightSlider <- tkscale(top, from=0, to=50, showvalue=TRUE, variable=outputHeightVar,
        resolution=5, orient="horizontal")   
    contrasts1 <- tclVar(contrasts[1])
    contrasts2 <- tclVar(contrasts[2])
    contrastsFrame <- tkframe(top)
    contrasts1Entry <- tkentry(contrastsFrame, width="15", textvariable=contrasts1)  
    contrasts2Entry <- tkentry(contrastsFrame, width="15", textvariable=contrasts2) 
    grabFocusVar <- tclVar(as.numeric(grab.focus))
    grabFocusCheckBox <- tkcheckbutton(top, variable=grabFocusVar)
    doubleClickVar <- tclVar(as.numeric(double.click))
    doubleClickCheckBox <- tkcheckbutton(top, variable=doubleClickVar)
    sortNamesVar <- tclVar(as.numeric(sort.names))
    sortNamesCheckBox <- tkcheckbutton(top, variable=sortNamesVar)
    showEditButtonVar <- tclVar(as.numeric(show.edit.button))
    showEditButtonCheckBox <- tkcheckbutton(top, variable=showEditButtonVar)
    scaleFactorVar <- tclVar(if (is.null(scale.factor)) 1.0 else scale.factor)
    scaleFactorSlider <- tkscale(top, from=0.2, to=3.0, showvalue=TRUE, variable=scaleFactorVar,
        resolution=0.2, orient="horizontal")        
    defaultFont <- tclVar(default.font)
    defaultFontEntry <- tkentry(top, width="30", textvariable=scaleFactorVar)                  
    onOK <- function(){
        log.font.size <- round(as.numeric(tclvalue(logFontSizeVar)))
        log.width <- round(as.numeric(tclvalue(logWidthVar)))
        log.height <- as.numeric(tclvalue(logHeightVar))
        log.commands <- as.logical(tclvalue(logCommandsVar) == "1") && (log.height != 0)
        output.height <- as.numeric(tclvalue(outputHeightVar))
        console.output <- as.logical(tclvalue(consoleOutputVar) == "1") || (output.height == 0)
        contrasts <- c(tclvalue(contrasts1), tclvalue(contrasts2))
        grab.focus <- tclvalue(grabFocusVar) == 1
        double.click <- tclvalue(doubleClickVar) == 1
        sort.names <- tclvalue(sortNamesVar) == 1
        show.edit.button <- tclvalue(showEditButtonVar) == 1
        scale.factor <- round(as.numeric(tclvalue(scaleFactorVar)), 1)
        if (scale.factor == 1) scale.factor <- NULL
        default.font <- tclvalue(defaultFont)
        options <- list(
            log.font.size=log.font.size,
            log.width=log.width,
            log.height=log.height,
            log.commands=log.commands,
            output.height=output.height,
            console.output=console.output,
            contrasts=contrasts,
            grab.focus=grab.focus,
            double.click=double.click,
            sort.names=sort.names,
            show.edit.button=show.edit.button
            )
        if (.Platform$OS.type == "windows") options$scale.factor <- scale.factor
            else options$default.font <- default.font
        options(Rcmdr=options)
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)  
        closeCommander()
        Commander()
        }
    OKCancelHelp(helpSubject="Commander")
    tkgrid(tklabel(top, text="Log commands to script window"), logCommandsCheckBox, sticky="e")
    tkgrid.configure(logCommandsCheckBox, sticky="w")
    tkgrid(tklabel(top, text="Log-font size (points)"), logFontSizeSlider, sticky="se")
    tkgrid.configure(logFontSizeSlider, sticky="w")
    tkgrid(tklabel(top, text="Log width (characters)"), logWidthSlider, sticky="se")
    tkgrid.configure(logWidthSlider, sticky="w")
    tkgrid(tklabel(top, text="Log height (lines)"), logHeightSlider, sticky="se")
    tkgrid.configure(logHeightSlider, sticky="w")
    tkgrid(tklabel(top, text=" "), sticky="w")
    tkgrid(tklabel(top, text="Send output to R Console"), consoleOutputCheckBox, sticky="e")
    tkgrid.configure(consoleOutputCheckBox, sticky="w")
    tkgrid(tklabel(top, text="Output height (lines)"), outputHeightSlider, sticky="se")
    tkgrid.configure(outputHeightSlider, sticky="w")
    tkgrid(tklabel(contrastsFrame, text="Unordered factors"), tklabel(contrastsFrame, text="   "),
        tklabel(contrastsFrame, text="Ordered factors"), sticky="w")
    tkgrid(contrasts1Entry, tklabel(contrastsFrame, text="   "), contrasts2Entry, sticky="w")
    tkgrid(tklabel(top, text="Contrasts"), contrastsFrame, sticky="se")
    tkgrid.configure(contrastsFrame, sticky="sw")
    tkgrid(tklabel(top, text="Active window grabs focus"), grabFocusCheckBox, sticky="e")
    tkgrid.configure(grabFocusCheckBox, sticky="w")
    tkgrid(tklabel(top, text="Double-click presses OK button"), doubleClickCheckBox, sticky="e")
    tkgrid.configure(doubleClickCheckBox, sticky="w")
    tkgrid(tklabel(top, text="Sort variable names alphabetically"), sortNamesCheckBox, sticky="e")
    tkgrid.configure(sortNamesCheckBox, sticky="w")
    tkgrid(tklabel(top, text="Show edit button"), showEditButtonCheckBox, sticky="e")
    tkgrid.configure(showEditButtonCheckBox, sticky="w")
    if (.Platform$OS.type == "windows"){
        tkgrid(tklabel(top, text="Scale factor for Tk elements"), scaleFactorSlider, sticky="se")
        tkgrid.configure(scaleFactorSlider, sticky="w")
        }
    else {
        tkgrid(tklabel(top, text="Default font"), defaultFontEntry, sticky="e")
        tkgrid.configure(defaultFontEntry, sticky="w")
        }
    tkgrid(buttonsFrame, columnspan=2, sticky="w")
    dialogSuffix(rows=11, columns=2)
    }

setOutputWidth <- function(){
    initializeDialog(title="Reset Output Width")
    output.width <- unlist(options("width"))
    outputWidthVar <- tclVar(output.width)
    logWidthSlider <- tkscale(top, from=20, to=200, showvalue=TRUE, variable=outputWidthVar,
        resolution=10, orient="horizontal")    
    onOK <- function(){
        output.width <- round(as.numeric(tclvalue(outputWidthVar)))
        doItAndPrint(paste("options(width=", output.width, ")", sep=""))
        if (.grab.focus) tkgrab.release(top)
        tkfocus(.commander)
        tkdestroy(top)  
        }
    OKCancelHelp(helpSubject="options")
    tkgrid(tklabel(top, text="Output width (characters)"), logWidthSlider, sticky="w")
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix(rows=2, columns=1)
    }
   
loadPackages <- function(){
    currentPackages <- .packages()
    allPackages <- .packages(all.available = TRUE)
    availablePackages <- sort(setdiff(allPackages, currentPackages))
    initializeDialog(title="Load Packages")
    packagesBox <- variableListBox(top, availablePackages, title="Packages (pick one or more)",
        selectmode="multiple", listHeight=10)
    onOK <- function(){
        packages <- getSelection(packagesBox)
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        if (length(packages) == 0){
            errorCondition(recall=loadPackages, message="You must select at least one package.")
            return()
            }
        for (package in packages) {
            command <- paste('library("', package, '", character.only=TRUE)', sep="")
            justDoIt(command)
            }
        }
    OKCancelHelp(helpSubject="library")
    tkgrid(getFrame(packagesBox), sticky="nw")    
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix(rows=1, columns=1)
    }
# Graphs menu dialogs

# last modified 4 Dec 04 by J. Fox

indexPlot <- function(){
    if(!checkActiveDataSet()) return()
    if(!checkNumeric()) return()
    initializeDialog(title="Index Plot")
    xBox <- variableListBox(top, .numeric, title="Variable (pick one)")
    onOK <- function(){
        x <- getSelection(xBox)
        if (length(x) == 0){
            errorCondition(recall=indexPlot, message="You must select a variable")
            return()
            }
        type <- if (tclvalue(typeVariable) == "spikes") "h" else "p"
        identify <- tclvalue(identifyVariable) == "1"
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        command <- paste("plot(", .activeDataSet, "$", x, ', type="', type, '")', sep="")
        doItAndPrint(command)
        if (par("usr")[3] <= 0) doItAndPrint('abline(h=0, col="gray")')
        if (identify) {
            command <- paste("identify(", .activeDataSet, "$", x, 
                ", labels=rownames(", .activeDataSet, "))", sep="")
            doItAndPrint(command)
            }        
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="plot")
    optionsFrame <- tkframe(top)
    typeVariable <- tclVar("spikes")
    spikesButton <- tkradiobutton(optionsFrame, variable=typeVariable, value="spikes")
    pointsButton <- tkradiobutton(optionsFrame, variable=typeVariable, value="points")
    identifyVariable <- tclVar("0")
    identifyCheckBox <- tkcheckbutton(optionsFrame, variable=identifyVariable)
    tkgrid(getFrame(xBox), sticky="nw")    
    tkgrid(tklabel(optionsFrame, text="Identify observations\nwith mouse", justify="left"), 
        identifyCheckBox, sticky="w")
    tkgrid(tklabel(optionsFrame, text="Spikes"), spikesButton, sticky="w")
    tkgrid(tklabel(optionsFrame, text="Points"), pointsButton, sticky="w")
    tkgrid(optionsFrame, sticky="w")
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix(rows=2, columns=1)
    }

Histogram <- function(){
    if (!checkActiveDataSet()) return()
    if(!checkNumeric()) return()
    initializeDialog(title="Histogram")
    xBox <- variableListBox(top, .numeric, title="Variable (pick one)")
    onOK <- function(){
        x <- getSelection(xBox)
        if (length(x) == 0){
            errorCondition(recall=Histogram, message="You must select a variable")
            return()
            }
        bins <- tclvalue(binsVariable)
        bins <- if (bins == "<auto>") '"Sturges"' else as.numeric(bins)
        scale <- tclvalue(scaleVariable)
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        command <- paste("Hist(", .activeDataSet, "$", x, ', scale="',
            scale, '", breaks=', bins, ', col="darkgray")', sep="")
        doItAndPrint(command)
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="Hist")
    radioButtons(name="scale", buttons=c("frequency", "percent", "density"),
        labels=c("Frequency counts", "Percentages", "Densities"), title="Axis Scaling")
    binsFrame <- tkframe(top)
    binsVariable <- tclVar("<auto>")
    binsField <- tkentry(binsFrame, width="6", textvariable=binsVariable)
    tkgrid(getFrame(xBox), sticky="nw")    
    tkgrid(tklabel(binsFrame, text="Number of bins: "), binsField, sticky="w")
    tkgrid(binsFrame, sticky="w")
    tkgrid(scaleFrame, sticky="w")
    tkgrid(buttonsFrame, sticky="w")
    tkgrid.configure(binsField, sticky="e")
    dialogSuffix(rows=4, columns=1)
    }

stemAndLeaf <- function(){
    if (!checkActiveDataSet()) return()
    if (!checkNumeric()) return()
    initializeDialog(title="Stem and Leaf Display")
    xBox <- variableListBox(top, .numeric, title="Variable (pick one)")
    displayDigits <- tclVar("1")
    onDigits <- function(...){
        tclvalue(displayDigits) <- formatC(10^as.numeric(tclvalue(leafsDigitValue)), 
            format="fg", big.mark=",")
        tclvalue(leafsAutoVariable) <- "0"
        }
    radioButtons(name="parts", buttons=c("auto", "one", "two", "five"), 
        values=c("auto", "1", "2", "5"), labels=c("Automatic", "   1", "   2", "   5"),
        title="Parts Per Stem")
    radioButtons(name="style", buttons=c("Tukey", "bare"), labels=c("Tukey", "Repeated stem digits"),
        title="Style of Divided Stems")
    checkBoxes(frame="optionsFrame", boxes=c("trimOutliers", "showDepths", "reverseNegative"), 
        initialValues=rep(1, 3), labels=c("Trim outliers", "Show depths", "Reverse negative leaves"))
    leafsFrame <- tkframe(top)
    leafsDigitValue <- tclVar("0")
    leafsDigitSlider <- tkscale(leafsFrame, from=-6, to=6, showvalue=FALSE, variable=leafsDigitValue,
        resolution=1, orient="horizontal", command=onDigits)
    leafsDigitShow <- tklabel(leafsFrame, textvariable=displayDigits, width=8, justify="right")
    leafsAutoVariable <- tclVar("1")
    leafsDigitCheckBox <- tkcheckbutton(leafsFrame, variable=leafsAutoVariable)
    onOK <- function(){
        x <- getSelection(xBox)
        if (length(x) == 0){
            errorCondition(recall=stemAndLeaf, message="You must select a variable")
            return()
            }
        unit <- if (tclvalue(leafsAutoVariable) == "1") "" 
            else paste(", unit=", 10^as.numeric(tclvalue(leafsDigitValue)), sep="")
        m <- if (tclvalue(partsVariable) == "auto") ""
            else paste(", m=", tclvalue(partsVariable), sep="")
        trim <- if (tclvalue(trimOutliersVariable) == "1") ""
            else ", trim.outliers=FALSE"
        depths <- if (tclvalue(showDepthsVariable) == "1") ""
            else ", depths=FALSE"
        reverse <- if (tclvalue(reverseNegativeVariable) == "1") ""
            else ", reverse.negative.leaves=FALSE"
        style <- if (tclvalue(styleVariable) == "Tukey") ""
            else ', style="bare"'
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        command <- paste("stem.leaf(", .activeDataSet, "$", x, style, unit, m, trim, 
            depths, reverse, ")", sep="")
        doItAndPrint(command)
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="stem.leaf")
    tkgrid(getFrame(xBox), sticky="nw")
    tkgrid(tklabel(leafsFrame, text="Leafs Digit:  ", fg="blue"),
        tklabel(leafsFrame, text="Automatic"), leafsDigitCheckBox,
        tklabel(leafsFrame, text="  or set:", fg="red"), leafsDigitShow, leafsDigitSlider, sticky="w")  
    tkgrid(leafsFrame, sticky="w") 
    tkgrid(partsFrame, sticky="w")
    tkgrid(styleFrame, sticky="w")
    tkgrid(tklabel(top, text="Options", fg="blue"), sticky="w")
    tkgrid(optionsFrame, sticky="w")
    tkgrid(buttonsFrame, sticky="w")
    tclvalue(leafsAutoVariable) <- "1"
    dialogSuffix(rows=7, columns=1)
    }

boxPlot <- function(){
    if (!checkActiveDataSet()) return()
    if (!checkNumeric()) return()
    initializeDialog(title="Boxplot")
    xBox <- variableListBox(top, .numeric, title="Variable (pick one)")
    identifyVariable <- tclVar("0")
    identifyFrame <- tkframe(top)
    identifyCheckBox <- tkcheckbutton(identifyFrame, variable=identifyVariable)
    .groups <- FALSE
    onOK <- function(){
        x <- getSelection(xBox)
        if (length(x) == 0){
            errorCondition(recall=boxPlot, message="You must select a variable")
            return()
            }
        identifyPoints <- "1" == tclvalue(identifyVariable)
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        var <- paste(.activeDataSet, "$", x, sep="")
        if (.groups == FALSE) {
            command <- (paste("boxplot(", var, ', ylab="', x, '")', sep=""))
            logger(command)
            justDoIt(command)     
            if (identifyPoints) doItAndPrint(paste("identify(rep(1, length(", var,
                ")), ", var, ", rownames(", .activeDataSet,"))", sep=""))           
            }
        else {
            command <- (paste("boxplot(", x, "~", .groups, ', ylab="', x, 
                '", xlab="', .groups,'"',
                ", data=", .activeDataSet, ")", sep=""))
            logger(command)
            justDoIt(command)
            if (identifyPoints) doItAndPrint(paste("identify(", .activeDataSet, "$", .groups, ", ", var,
                ", rownames(", .activeDataSet,"))", sep=""))
            }
        tkfocus(.commander)
        }
    groupsBox(boxPlot)
    OKCancelHelp(helpSubject="boxplot")
    tkgrid(getFrame(xBox), sticky="nw")    
    tkgrid(tklabel(identifyFrame, text="Identify outliers with mouse", justify="left"), 
        identifyCheckBox, sticky="w")
    tkgrid(identifyFrame, stick="w")
    tkgrid(groupsFrame, sticky="w")
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix(rows=4, columns=1)
    }

scatterPlot <- function(){
    if (!checkActiveDataSet()) return()
    if (!checkNumeric(2)) return()
    initializeDialog(title="Scatterplot")
    xBox <- variableListBox(top, .numeric, title="x-variable (pick one)")
    yBox <- variableListBox(top, .numeric, title="y-variable (pick one)")
    checkBoxes(frame="optionsFrame", boxes=c("identify", "jitterX", "jitterY", "boxplots", "lsLine", "smoothLine"),
        initialValues=c(0, 0, 0, 1, 1, 1), labels=c("Identify points", "Jitter x-variable", "Jitter y-variable",
        "Marginal boxplots", "Least-squares line", "Smooth Line"))
    sliderValue <- tclVar("50")
    slider <- tkscale(optionsFrame, from=0, to=100, showvalue=TRUE, variable=sliderValue,
        resolution=5, orient="horizontal")
    subsetBox()
    onOK <- function(){
        x <- getSelection(xBox)
        y <- getSelection(yBox)
        if (length(x) == 0 || length(y) == 0){
            errorCondition(recall=scatterPlot, message="You must select two variables")
            return()
            }
        if (x == y) {
            errorCondition(recall=scatterPlot, message="x and y variables must be different")
            return()
            }
        if ("1" == tclvalue(jitterXVariable)) x <- paste("jitter(", x, ")", sep="")
        if ("1" == tclvalue(jitterYVariable)) y <- paste("jitter(", y, ")", sep="")
        labels <- if("1" == tclvalue(identifyVariable)) 
            paste("rownames(", .activeDataSet, ")", sep="") else "FALSE"
        box <- if ("1" == tclvalue(boxplotsVariable)) "'xy'" else "FALSE"
        line <- if("1" == tclvalue(lsLineVariable)) "lm" else "FALSE"
        smooth <- as.character("1" == tclvalue(smoothLineVariable))
        span <- as.numeric(tclvalue(sliderValue))
        subset <- tclvalue(subsetVariable)
        subset <- if (trim.blanks(subset) == "<all valid cases>") "" 
            else paste(", subset=", subset, sep="")
        if (.grab.focus) tkgrab.release(top)
        tkfocus(.commander)
        tkdestroy(top)
        if (.groups == FALSE) {
            doItAndPrint(paste("scatterplot(", y, "~", x,
                ", reg.line=", line, ", smooth=", smooth, ", labels=", labels,
                ", boxplots=", box, ", span =", span/100,
                ", data=", .activeDataSet, subset, ")", sep=""))
            }
        else {
            doItAndPrint(paste("scatterplot(", y, "~", x," | ", .groups,
                ", reg.line=", line, ", smooth=", smooth, ", labels=", labels,
                ", boxplots=", box, ", span=", span/100,
                ", by.groups=", .linesByGroup,
                ", data=", .activeDataSet, subset, ")", sep=""))
            }
        }
    groupsBox(scatterPlot, plotLinesByGroup=TRUE, positionLegend=TRUE)
    OKCancelHelp(helpSubject="scatterplot")
    tkgrid(getFrame(xBox), getFrame(yBox), sticky="nw")    
    tkgrid(tklabel(optionsFrame, text="Span for smooth"), slider, sticky="w")
    tkgrid(optionsFrame, sticky="w")
    tkgrid(subsetFrame, sticky="w")
    tkgrid(groupsFrame, sticky="w")
    tkgrid(buttonsFrame, columnspan=2, sticky="w")
    dialogSuffix(rows=5, columns=2)
    }

scatterPlotMatrix <- function(){
    if (!checkActiveDataSet()) return()
    if (!checkNumeric(3)) return()
    initializeDialog(title="Scatterplot Matrix")
    variablesBox <- variableListBox(top, .numeric, title="Select variables (three or more)",
        selectmode="multiple", initialSelection=NULL)
    checkBoxes(frame="optionsFrame", boxes=c("lsLine", "smoothLine"), initialValues=rep(1,2),
        labels=c("Least-squares lines", "Smooth lines"))
    sliderValue <- tclVar("50")
    slider <- tkscale(optionsFrame, from=0, to=100, showvalue=TRUE, variable=sliderValue,
        resolution=5, orient="horizontal")
    radioButtons(name="diagonal", buttons=c("density", "histogram", "boxplot", "qqplot", "none"),
        labels=c("Density plots", "Histograms", "Boxplots", "Normal QQ plots", "Nothing (empty)"),
        title="On Diagonal")
    subsetBox()
    onOK <- function(){
        variables <- getSelection(variablesBox)
        if (length(variables) < 3) {
            errorCondition(recall=scatterPlotMatrix, message="Fewer than 3 variable selected.")
            return()
            }
        line <- if("1" == tclvalue(lsLineVariable)) "lm" else "FALSE"
        smooth <- as.character("1" == tclvalue(smoothLineVariable))
        span <- as.numeric(tclvalue(sliderValue))
        diag <- as.character(tclvalue(diagonalVariable))
        subset <- tclvalue(subsetVariable)
        subset <- if (trim.blanks(subset) == "<all valid cases>") "" 
            else paste(", subset=", subset, sep="")
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        if (.groups == FALSE) {
           command <- paste("scatterplot.matrix(~", paste(variables, collapse="+"),
                ", reg.line=", line, ", smooth=", smooth,
                ", span=", span/100, ", diagonal = '", diag,
                "', data=", .activeDataSet, subset, ")", sep="")
           logger(command)
           justDoIt(command)
            }
        else {
            command <- paste("scatterplot.matrix(~", paste(variables, collapse="+")," | ", .groups,
                ", reg.line=", line, ", smooth=", smooth,
                ", span=", span/100, ", diagonal= '", diag,
                "', by.groups=", .linesByGroup,
                ", data=", .activeDataSet, subset, ")", sep="")
            logger(command)
            justDoIt(command)
            }
        tkfocus(.commander)
        }
    groupsBox(scatterPlot, plotLinesByGroup=TRUE)
    OKCancelHelp(helpSubject="scatterplot.matrix")
    tkgrid(getFrame(variablesBox), sticky="nw")    
    tkgrid(optionsFrame, sticky="w")
    tkgrid(diagonalFrame, sticky="w")
    tkgrid(subsetFrame, sticky="w")
    tkgrid(groupsFrame, sticky="w")
    tkgrid(buttonsFrame, columnspan=2, sticky="w")
    dialogSuffix(rows=6, columns=2)
    }

barGraph <- function(){
    if (!checkActiveDataSet()) return()
    if (!checkFactors()) return()
    initializeDialog(title="Bar Graph")
    variableBox <- variableListBox(top, .factors, title="Variable (pick one)")
    onOK <- function(){
        variable <- getSelection(variableBox)
        if (length(variable) == 0){
            errorCondition(recall=barGraph, message="You must select a variable")
            return()
            }
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        command <- paste("barplot(table(", .activeDataSet, "$", variable, '), xlab="',
            variable, '", ylab="Frequency")', sep="")
        logger(command)
        justDoIt(command)
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="barplot")
    tkgrid(getFrame(variableBox), sticky="nw")
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix(rows=2, columns=1)
    }

pieChart <- function(){
    if (!checkActiveDataSet()) return()
    if (!checkFactors()) return()
    initializeDialog(title="Pie Chart")
    variableBox <- variableListBox(top, .factors, title="Variable (pick one)")
    onOK <- function(){
        variable <- getSelection(variableBox)
        if (length(variable) == 0){
            errorCondition(recall=pieChart, message="You must select a variable")
            return()
            }
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        command <- (paste("pie(table(", .activeDataSet, "$", variable, "), labels=levels(",
            .activeDataSet, "$", variable, '), main="', variable, '", col=rainbow(length(levels(',
            .activeDataSet, "$", variable, "))))", sep=""))
        logger(command)
        justDoIt(command)
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="pie")
    tkgrid(getFrame(variableBox), sticky="nw")
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix(rows=3, columns=1)
    }

linePlot <- function(){
    if (!checkActiveDataSet()) return()
    if (!checkNumeric(2)) return()
    initializeDialog(title="Line Plot")
    variablesFrame <- tkframe(top)
    xBox <- variableListBox(variablesFrame, .numeric, title="x variable (pick one)")
    yBox <- variableListBox(variablesFrame, .numeric, title="y variables (pick one or more)", 
        selectmode="multiple", initialSelection=NULL)
    axisLabelVariable <- tclVar("<use y-variable names>")
    axisLabelFrame <- tkframe(top)
    axisLabelEntry <- tkentry(axisLabelFrame, width="40", textvariable=axisLabelVariable)
    axisLabelScroll <- tkscrollbar(axisLabelFrame, orient="horizontal",
        repeatinterval=5, command=function(...) tkxview(axisLabelEntry, ...))
    tkconfigure(axisLabelEntry, xscrollcommand=function(...) tkset(axisLabelScroll, ...))
    legendFrame <- tkframe(top)
    legendVariable <- tclVar("0")
    legendCheckBox <- tkcheckbutton(legendFrame, variable=legendVariable)
    onOK <- function(){
        y <- getSelection(yBox)
        x <- getSelection(xBox)
        if (0 == length(x)) {
            errorCondition(recall=linePlot, message="No x variable selected.") 
            return()
            }
        if (0 == length(y)) {
            errorCondition(recall=linePlot, message="No y variables selected.") 
            return()
            }
        if (is.element(x, y)) {
            errorCondition(recall=linePlot, message="x and y variables must be different.")
            return()
            }
        .x <- na.omit(eval(parse(text=paste(.activeDataSet, "$", x, sep="")), envir=.GlobalEnv))
        if (!identical(order(.x), seq(along=.x))){
            response <- tclvalue(tkmessageBox(message="x-values are not in order.\nContinue?", 
                icon="warning", type="okcancel", default="cancel"))
            if (response == "cancel") {
                onCancel()
                return()
                }
            }
        axisLabel <- tclvalue(axisLabelVariable)
        legend <- tclvalue(legendVariable) == "1"
        if (axisLabel == "<use y-variable names>"){
            axisLabel <- if (legend) ""
                else if(length(y) == 1) y
                else paste(paste("(", 1:length(y), ") ", y, sep=""), collapse=", ")
            }
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        pch <- if (length(y) == 1) ", pch=1" else ""
        command <- paste("matplot(", .activeDataSet, "$", x, ", ", .activeDataSet, "[, ",
            paste("c(", paste(paste('"', y, '"', sep=""), collapse=","), ")", sep=""),
            '], type="b", lty=1, ylab="', axisLabel, '"', pch, ")", sep="")
        logger(command)
        justDoIt(command)
        if (legend && length(y) > 1){
            n <- length(y)
            cols <- rep(1:6, 1 + n %/% 6)[1:n]
            command <- paste("legend(locator(1), legend=", 
                paste("c(", paste(paste('"', y, '"', sep=""), collapse=","), ")", sep=""),
                ", col=c(", paste(cols, collapse=","), "), lty=1, pch=c(",
                paste(paste('"', as.character(1:n), '"', sep=""), collapse=","), "))", sep="")
            logger(command)
            justDoIt(command)
            }
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="matplot")
    tkgrid(getFrame(xBox), tklabel(variablesFrame, text="    "), getFrame(yBox), sticky="nw")
    tkgrid(variablesFrame, sticky="nw")    
    tkgrid(tklabel(axisLabelFrame, text="Label for y-axis", fg="blue"), sticky="w")
    tkgrid(axisLabelEntry, sticky="w")
    tkgrid(axisLabelScroll, sticky="ew")
    tkgrid(axisLabelFrame, sticky="w")
    tkgrid(tklabel(legendFrame, text="Plot legend (position with mouse click)"),
        legendCheckBox, sticky="w")
    tkgrid(legendFrame, sticky="w")
    tkgrid(buttonsFrame, stick="w")
    dialogSuffix(rows=4, columns=1)
    }
    
QQPlot <- function()
# this function modified by Martin Maechler
{
    if (!checkActiveDataSet()) return()
    if (!checkNumeric()) return()
    initializeDialog(title="Quantile-Comparison (QQ) Plot")
    xBox <- variableListBox(top, .numeric, title="Variable (pick one)")
    onOK <- function(){
        x <- getSelection(xBox)
       if (0 == length(x)) {
            errorCondition(recall=QQPlot, message="You must select a variable.") 
            return()
            }
        dist <- tclvalue(distVariable)
        save <- options(warn=-1)
        on.exit(options=save)
        retryMe <- function(msg) {
            tkmessageBox(message= msg, icon="error", type="ok")
            if (.grab.focus) tkgrab.release(top)
            tkdestroy(top)
            QQPlot()
        }
        switch(dist,
               "norm" = { args <- 'dist= "norm"' },
               "t" =  {
                   df <- tclvalue(tDfVariable)
                   df.num <- as.numeric(df)
                   if (is.na(df.num) || df.num < 1) {
                       retryMe("df for t must be a positive number.")
                       return()
                   }
                   args <- paste('dist="t", df=', df, sep="")
               },
               "chisq" = {
                   df <- tclvalue(chisqDfVariable)
                   df.num <- as.numeric(df)
                   if (is.na(df.num) || df.num < 1) {
                       retryMe("df for chi-square must be a positive number.")
                       return()
                   }
                   args <- paste('dist="chisq", df=', df, sep="")
               },
               "f" = {
                   df1 <- tclvalue(FDf1Variable)
                   df2 <- tclvalue(FDf2Variable)
                   df.num1 <- as.numeric(df1)
                   df.num2 <- as.numeric(df2)
                   if (is.na(df.num1) || df.num1 < 1 ||
                       is.na(df.num2) || df.num2 < 1) {
                       retryMe("numerator and denominator \ndf for F must be positive numbers.")
                       return()
                   }
                   args <- paste('dist="f", df1=', df1, ', df2=', df2, sep="")
               },
               ## else -- other `dist' :
           {
               dist <- tclvalue(otherNameVariable)
               params <- tclvalue(otherParamsVariable)
               args <- paste('dist="', dist,'", ', params, sep="")
           }) # end{switch}
        labels <-
            if ("1" == tclvalue(identifyVariable))
                paste("rownames(", .activeDataSet, ")", sep="")
            else "FALSE"
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        command <- paste("qq.plot", "(", .activeDataSet, "$", x, ", ", args,
                          ", labels=", labels, ")", sep="")
        doItAndPrint(command)
        tkfocus(.commander)
    }
    OKCancelHelp(helpSubject="qq.plot")
    distFrame <- tkframe(top)
    distVariable <- tclVar("norm")
    normalButton <- tkradiobutton(distFrame, variable=distVariable, value="norm")
    tButton <- tkradiobutton(distFrame, variable=distVariable, value="t")
    chisqButton <- tkradiobutton(distFrame, variable=distVariable, value="chisq")
    FButton <- tkradiobutton(distFrame, variable=distVariable, value="f")
    otherButton <- tkradiobutton(distFrame, variable=distVariable, value="other")
    tDfFrame <- tkframe(distFrame)
    tDfVariable <- tclVar("")
    tDfField <- tkentry(tDfFrame, width="6", textvariable=tDfVariable)
    chisqDfFrame <- tkframe(distFrame)
    chisqDfVariable <- tclVar("")
    chisqDfField <- tkentry(chisqDfFrame, width="6", textvariable=chisqDfVariable)
    FDfFrame <- tkframe(distFrame)
    FDf1Variable <- tclVar("")
    FDf1Field <- tkentry(FDfFrame, width="6", textvariable=FDf1Variable)
    FDf2Variable <- tclVar("")
    FDf2Field <- tkentry(FDfFrame, width="6", textvariable=FDf2Variable)
    otherParamsFrame <- tkframe(distFrame)
    otherParamsVariable <- tclVar("")
    otherParamsField <- tkentry(otherParamsFrame, width="30", textvariable=otherParamsVariable)
    otherNameVariable <- tclVar("")
    otherNameField <- tkentry(otherParamsFrame, width="10", textvariable=otherNameVariable)
    identifyVariable <- tclVar("0")
    identifyFrame <- tkframe(top)
    identifyCheckBox <- tkcheckbutton(identifyFrame, variable=identifyVariable)
    tkgrid(getFrame(xBox), sticky="nw")
    tkgrid(tklabel(identifyFrame, text="Identify observations with mouse"),
           identifyCheckBox, sticky="w")
    tkgrid(identifyFrame, sticky="w")
    tkgrid(tklabel(distFrame, text="Distribution", fg="blue"), columnspan=6, sticky="w")
    tkgrid(tklabel(distFrame, text="Normal"), normalButton, sticky="w")
    tkgrid(tklabel(tDfFrame, text="df = "), tDfField, sticky="w")
    tkgrid(tklabel(distFrame, text="t"), tButton, tDfFrame, sticky="w")
    tkgrid(tklabel(chisqDfFrame, text="df = "), chisqDfField, sticky="w")
    tkgrid(tklabel(distFrame, text="Chi-square"), chisqButton,
           chisqDfFrame, sticky="w")
    tkgrid(tklabel(FDfFrame, text="Numerator df = "), FDf1Field,
           tklabel(FDfFrame, text="Denominator df = "), FDf2Field, sticky="w")
    tkgrid(tklabel(distFrame, text="F"), FButton, FDfFrame, sticky="w")
    tkgrid(tklabel(otherParamsFrame, text="Specify: "),
           otherNameField, tklabel(otherParamsFrame, text="Parameters: "),
           otherParamsField, sticky="w")
    tkgrid(tklabel(distFrame, text="Other"), otherButton,
           otherParamsFrame, sticky="w")
    tkgrid(distFrame, sticky="w")
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix(rows=5, columns=1)
    }

PlotMeans <- function(){
    if (!checkActiveDataSet()) return()
    if (!checkNumeric()) return()
    if (!checkFactors()) return()
    initializeDialog(title="Plot Means")
    groupBox <- variableListBox(top, .factors, title="Factors (pick one or two)", selectmode="multiple")
    responseBox <- variableListBox(top, .numeric, title="Response Variable (pick one)")
    onOK <- function(){
        groups <- getSelection(groupBox)
        response <- getSelection(responseBox)
        if (0 == length(groups)) {
            errorCondition(recall=PlotMeans, message="No factors selected.")
            return()
            }
        if (2 < length(groups)) {
            errorCondition(recall=PlotMeans, message="More than two factors selected.")
            return()
            }
        if (0 == length(response)) {
            errorCondition(recall=PlotMeans, message="No response variable selected.")
            return()
            }
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        error.bars <- tclvalue(errorBarsVariable)
        level <- if (error.bars == "conf.int") paste(", level=", tclvalue(levelVariable), sep="") else ""
        if (length(groups) == 1) doItAndPrint(paste("plotMeans(", .activeDataSet, "$", response, 
            ", ", .activeDataSet, "$", groups[1], 
            ', error.bars="', error.bars, '"', level, ')', sep=""))
        else {
            if (eval(parse(text=paste("length(levels(", .activeDataSet, "$", groups[1], 
                ")) < length(levels(", .activeDataSet, "$", groups[2], "))", sep=""))))
                groups <- rev(groups)
            doItAndPrint(paste("plotMeans(", .activeDataSet, "$", response, ", ", .activeDataSet, "$", groups[1], 
                ", ", .activeDataSet, "$", groups[2], ', error.bars="', error.bars, '"', level, ')', sep=""))
            }
        tkfocus(.commander)
        }
    optionsFrame <- tkframe(top)
    errorBarsVariable <- tclVar("se")
    seButton <- tkradiobutton(optionsFrame, variable=errorBarsVariable, value="se")
    sdButton <- tkradiobutton(optionsFrame, variable=errorBarsVariable, value="sd")
    confIntButton <- tkradiobutton(optionsFrame, variable=errorBarsVariable, value="conf.int")
    noneButton <- tkradiobutton(optionsFrame, variable=errorBarsVariable, value="none")
    levelVariable <- tclVar("0.95")
    levelEntry <- tkentry(optionsFrame, width="6", textvariable=levelVariable)    
    buttonsFrame <- tkframe(top)
    OKCancelHelp(helpSubject="plotMeans")
    tkgrid(getFrame(groupBox), getFrame(responseBox), sticky="nw")
    tkgrid(tklabel(optionsFrame, text="Error Bars", fg="blue"), sticky="w")
    tkgrid(tklabel(optionsFrame, text="Standard errors"), seButton, sticky="w")
    tkgrid(tklabel(optionsFrame, text="Standard deviations"), sdButton, sticky="w")
    tkgrid(tklabel(optionsFrame, text="Confidence intervals"), confIntButton,
        tklabel(optionsFrame, text="   Level of confidence:"), levelEntry, sticky="w")
    tkgrid(tklabel(optionsFrame, text="No error bars"), noneButton, sticky="w")
    tkgrid(optionsFrame, columnspan=2, sticky="w")
    tkgrid(buttonsFrame, columnspan=2, sticky="w")
    dialogSuffix(rows=3, columns=2)
    }

Scatter3D <- function(){
    if (!.rglPackage) {
        tkmessageBox(message="rgl package not present:\n3D plots unavailable.",
            icon="error", type="ok", default="ok")
        tkfocus(.commander)
        return()
        }
    if (!checkActiveDataSet()) return()
    if (!checkNumeric(3)) return()
    initializeDialog(title="3D Scatterplot")
    variablesFrame <- tkframe(top)
    xBox <- variableListBox(variablesFrame, .numeric, title="Explanatory variables (pick two)", selectmode="multiple",
        initialSelection=NULL)
    yBox <- variableListBox(variablesFrame, .numeric, title="Response variable (pick one)")
    surfacesFrame <- tkframe(top)
    gridLines <- tclVar("1")
    gridLinesCheckBox <- tkcheckbutton(surfacesFrame, variable=gridLines)
    linearLSSurface <- tclVar("1")
    linearLSCheckBox <- tkcheckbutton(surfacesFrame, variable=linearLSSurface)
    quadLSSurface <- tclVar("0")
    quadLSCheckBox <- tkcheckbutton(surfacesFrame, variable=quadLSSurface)
    nonparSurface <- tclVar("0")
    nonparCheckBox <- tkcheckbutton(surfacesFrame, variable=nonparSurface)
    dfNonparVariable <- tclVar("<auto>")
    dfNonparField <- tkentry(surfacesFrame, width="6", textvariable=dfNonparVariable)
    additiveSurface <- tclVar("0")
    additiveCheckBox <- tkcheckbutton(surfacesFrame, variable=additiveSurface)
    dfAddVariable <- tclVar("<auto>")
    dfAddField <- tkentry(surfacesFrame, width="6", textvariable=dfAddVariable)
    bgFrame <- tkframe(top)
    bgVariable <-tclVar("white")
    whiteButton <- tkradiobutton(bgFrame, variable=bgVariable, value="white")
    blackButton <- tkradiobutton(bgFrame, variable=bgVariable, value="black")
    onOK <- function(){
        x <- getSelection(xBox)
        y <- getSelection(yBox)
        if (length(y) == 0) {
            errorCondition(recall=Scatter3D, message="You must select a response variable.")
            return()
            }
        if (2 != length(x)) {
            errorCondition(recall=Scatter3D, message="You must select 2 explanatory variables.")
            return()
            }
        if (is.element(y, x)) {
            errorCondition(recall=Scatter3D, message="Response and explanatory variables must be different.")
            return()
            }
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        grid <- if (tclvalue(gridLines) == 1) "TRUE" else "FALSE"
        lin <- if(tclvalue(linearLSSurface) == 1) '"linear"'
        quad <- if(tclvalue(quadLSSurface) == 1) '"quadratic"'
        nonpar <- if (tclvalue(nonparSurface) == 1) '"smooth"'
        additive <- if (tclvalue(additiveSurface) == 1) '"additive"'
        surfaces <- c(lin, quad, nonpar, additive)
        nsurfaces <- length(surfaces)
        dfNonpar <- tclvalue(dfNonparVariable)
        dfNonpar <- if (dfNonpar == "<auto>") "" else paste(", df.smooth=", as.numeric(dfNonpar), sep="")
        dfAdd <- tclvalue(dfAddVariable)
        dfAdd <- if (dfAdd == "<auto>") "" else paste(", df.additive=", as.numeric(dfAdd), sep="")
        fit <- if (nsurfaces == 0) ", surface=FALSE"
            else if (nsurfaces == 1) paste(", fit=", surfaces, sep="")
            else paste(", fit=c(", paste(surfaces, collapse=","), ")", sep="")
        bg <- tclvalue(bgVariable)
        if (.groups != FALSE){ 
            groups <- paste(", groups=", .activeDataSet, "$", .groups, sep="")
            parallel <- paste(", parallel=", .linesByGroup, sep="")
            }
        else groups <- parallel <- ""                   
        command <- paste("scatter3d(", .activeDataSet, "$", x[1], ", ", 
            .activeDataSet, "$", y, ", ", .activeDataSet, "$", x[2], fit, dfNonpar, 
            dfAdd, groups, parallel, ', bg="', bg, '", grid=', grid, 
            ', xlab="', x[1], '", ylab="', y, '", zlab="', x[2], '")', sep="")
        doItAndPrint(command)
        assign(".rgl", TRUE, envir=.GlobalEnv)
        tkfocus(.commander)
        }
    groupsBox(Scatter3D, plotLinesByGroup=TRUE, plotLinesByGroupsText="Parallel regression surfaces")
    OKCancelHelp(helpSubject="Scatter3DDialog")
    tkgrid(getFrame(yBox), tklabel(variablesFrame, text="  "), getFrame(xBox), sticky="nw")
    tkgrid(variablesFrame, sticky="nw")   
    tkgrid(tklabel(surfacesFrame, text="Show surface grid lines"), gridLinesCheckBox, sticky="w")
    tkgrid(tklabel(surfacesFrame, text="Surfaces to Fit", fg="blue"), sticky="w")
    tkgrid(tklabel(surfacesFrame, text="Linear least-squares"), linearLSCheckBox, sticky="w")
    tkgrid(tklabel(surfacesFrame, text="Quadratic least-squares"), quadLSCheckBox, sticky="w")
    dfLabel <- tklabel(surfacesFrame, text="df = ")
    tkgrid(tklabel(surfacesFrame, text="Smooth regression"), nonparCheckBox, 
        dfLabel, dfNonparField, sticky="w")
    tkgrid.configure(dfLabel, sticky="e")
    tkgrid(tklabel(surfacesFrame, text="Additive regression"), additiveCheckBox, 
        tklabel(surfacesFrame, text="df(each term) = "), dfAddField, sticky="w")
    tkgrid(surfacesFrame, sticky="w") 
    tkgrid(tklabel(bgFrame, text="Background Color", fg="blue"), sticky="w", columnspan=2)
    tkgrid(tklabel(bgFrame, text="Black"), blackButton, sticky="w")
    tkgrid(tklabel(bgFrame, text="White"), whiteButton, sticky="w")
    tkgrid(bgFrame, sticky="w")
    tkgrid(groupsFrame, sticky="w")
    tkgrid(buttonsFrame, stick="w")
    dialogSuffix(rows=5, columns=1)
    }

saveBitmap <- function(){
    initializeDialog(title="Save Graph as Bitmap")
    if (1 == dev.cur()) {
        errorCondition(message="There is no current graphics device to save.")
        return()
        }
    radioButtons(name="filetype", buttons=c("png", "jpeg"), labels=c("PNG", "JPEG"), title="Graphics File Type")
    sliderFrame <- tkframe(top)
    widthVariable <- tclVar("500")
    widthSlider <- tkscale(sliderFrame, from=200, to=1000, showvalue=TRUE, variable=widthVariable,
        resolution=25, orient="horizontal")
    heightVariable <- tclVar("500")
    heightSlider <- tkscale(sliderFrame, from=200, to=1000, showvalue=TRUE, variable=heightVariable,
        resolution=25, orient="horizontal")
    onOK <- function(){
        width <- tclvalue(widthVariable)
        height <- tclvalue(heightVariable)
        type <- tclvalue(filetypeVariable)
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        if (type == "png"){
            ext <- "png"
            filetypes <- '{"PNG Files" {".png" ".PNG"}} {"All Files" {"*"}}'
            initial <- "RGraph.png"
            }
        else{
            ext <- "jpg"
            filetypes <- '{"JPEG Files" {".jpg" ".JPG" ".jpeg" ".JPEG"}} {"All Files" {"*"}}'
            initial <- "RGraph.jpg"
            }
        filename <- tclvalue(tkgetSaveFile(filetypes=filetypes, defaultextension=ext, initialfile=initial))
        if (filename == "") return()
        command <- paste('dev.print(', type, ', filename="', filename, '", width=', width, ', height=', height, ')', sep="")
        doItAndPrint(command)
        }
    OKCancelHelp(helpSubject="png")
    tkgrid(filetypeFrame, sticky="w")
    tkgrid(tklabel(sliderFrame, text="Width (pixels)"), widthSlider, sticky="sw")
    tkgrid(tklabel(sliderFrame, text="Height (pixels)"), heightSlider, sticky="sw")
    tkgrid(sliderFrame, sticky="w")
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix(rows=3, columns=1)
    }

savePDF <- function(){
    initializeDialog(title="Save Graph as PDF/Postscript")
    if (1 == dev.cur()) {
        errorCondition(message="There is no current graphics device to save.")
        return()
        }
    radioButtons(name="filetype", buttons=c("pdf", "postscript", "eps"), 
        labels=c("PDF", "Postscript", "Encapsulated Postscript"), title="Graphics File Type")
    sliderFrame <- tkframe(top)
    widthVariable <- tclVar("5")
    widthSlider <- tkscale(sliderFrame, from=3, to=10, showvalue=TRUE, variable=widthVariable,
        resolution=0.1, orient="horizontal")
    heightVariable <- tclVar("5")
    heightSlider <- tkscale(sliderFrame, from=3, to=10, showvalue=TRUE, variable=heightVariable,
        resolution=0.1, orient="horizontal")
    pointSizeVariable <- tclVar("10")
    pointSizeSlider <- tkscale(sliderFrame, from=6, to=14, showvalue=TRUE, variable=pointSizeVariable,
        resolution=1, orient="horizontal")
    onOK <- function(){
        width <- tclvalue(widthVariable)
        height <- tclvalue(heightVariable)
        type <- tclvalue(filetypeVariable)
        pointsize <- tclvalue(pointSizeVariable)
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        if (type == "pdf"){
            ext <- "pdf"
            filetypes <- '{"PDF Files" {".pdf" ".PDF"}} {"All Files" {"*"}}'
            initial <- "RGraph.pdf"
            }
        else if (type == "postscript") {
            ext <- "ps"
            filetypes <- '{"Postscript Files" {".ps" ".PS"}} {"All Files" {"*"}}'
            initial <- "RGraph.ps"
            }
        else {
            ext <- "eps"
            filetypes <- '{"Encapsulated Postscript Files" {".eps" ".EPS"}} {"All Files" {"*"}}'
            initial <- "RGraph.eps"
            }
        filename <- tclvalue(tkgetSaveFile(filetypes=filetypes, defaultextension=ext, initialfile=initial))
        if (filename == "") return()
        command <- if (type == "eps") paste('dev.copy2eps(file="', filename, '", width=', width, ', height=', height, 
                ', pointsize=', pointsize, ')', sep="")
            else paste('dev.print(', type, ', file="', filename, '", width=', width, ', height=', height, 
                ', pointsize=', pointsize, ')', sep="")
        doItAndPrint(command)
        }
    OKCancelHelp(helpSubject="pdf")
    tkgrid(filetypeFrame, sticky="w")
    tkgrid(tklabel(sliderFrame, text="Width (inches)"), widthSlider, sticky="sw")
    tkgrid(tklabel(sliderFrame, text="Height (inches)"), heightSlider, sticky="sw")
    tkgrid(tklabel(sliderFrame, text="Text size (points)"), pointSizeSlider, sticky="sw")
    tkgrid(sliderFrame, sticky="w")
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix(rows=3, columns=1)
    }

saveRglGraph <- function(){
    if (0 == rgl.cur()) {
        tkmessageBox(message="There is no current RGL graphics device to save.",
            icon="error", type="ok", default="ok")
        return()
        }  
    ext <- "png"
    filetypes <- '{"PNG Bitmap Files" {".png" ".PNG"}} {"All Files" {"*"}}'
    initial <- "RGLGraph.png"  
    filename <- tclvalue(tkgetSaveFile(filetypes=filetypes, defaultextension=ext, initialfile=initial))
    if (filename == "") return()
    command <- paste('rgl.snapshot("', filename, '")', sep="")
    doItAndPrint(command)
    }
# Model menu dialogs

# last modified 19 Nov 04 by J. Fox

selectActiveModel <- function(){
    models <- listAllModels()
    if (length(models) == 0){
        tkmessageBox(message="There are no models from which to choose.", 
                icon="error", type="ok")
        tkfocus(.commander)
        return()
        }
    initializeDialog(title="Select Model")
    initial <- if (is.null(.activeModel)) NULL else which(.activeModel == models) - 1
    modelsBox <- variableListBox(top, models, title="Models (pick one)", 
        initialSelection=initial)
    onOK <- function(){
        model <- getSelection(modelsBox)
        if (length(model) == 0) {
            if (.grab.focus) tkgrab.release(top)
            tkdestroy(top)
            tkfocus(.commander)
            return()
            }
        dataSet <- eval(parse(text=paste("as.character(", model, "$call$data)")))
        if (length(dataSet) == 0){
            errorCondition(message="There is no dataset associated with this model.")
            return()
            }
        dataSets <- listDataSets()
        if (!is.element(dataSet, dataSets)){
            errorCondition(message=paste("The dataset associated with this model, ", 
                dataSet, ", is not in memory.", sep=""))
            return()
            }
        if (is.null(.activeDataSet) || (dataSet != .activeDataSet)) activeDataSet(dataSet)
        activeModel(model)
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        tkfocus(.commander)
        }
    OKCancelHelp()
    nameFrame <- tkframe(top)
    tkgrid(tklabel(nameFrame, fg="blue", text="Current Model: "), 
        tklabel(nameFrame, text=tclvalue(.modelName)), sticky="w")
    tkgrid(nameFrame, sticky="w", columnspan="2")
    tkgrid(getFrame(modelsBox), columnspan="2", sticky="w")
    tkgrid(buttonsFrame, columnspan=2, sticky="w")
    dialogSuffix(rows=3, columns=2)
    }

summarizeModel <- function(){
    if (!checkActiveModel()) return()
    if (!checkMethod("summary", .activeModel)) return()
    doItAndPrint(paste("summary(", .activeModel, ")", sep=""))
    }

plotModel <- function(){
    if (!checkActiveModel()) return()
    if (!checkMethod("plot", .activeModel)) return()
    doItAndPrint("par(mfrow=c(2,2))")
    doItAndPrint(paste("plot(", .activeModel, ")", sep=""))
    doItAndPrint("par(mfrow=c(1,1))")
    }

CRPlots <- function(){
    if (!checkActiveModel()) return()
    if (!checkMethod("cr.plot", .activeModel)) return()
    doItAndPrint(paste("cr.plots(", .activeModel, ", ask=FALSE)", sep=""))
    }

AVPlots <- function(){
    if (!checkActiveModel()) return()
    if (!checkMethod("av.plot", .activeModel)) return()
    response <- tclvalue(tkmessageBox(message="Identify points with mouse?", 
        icon="question", type="yesno", default="no"))
    doItAndPrint(paste("av.plots(", .activeModel, ", ask=FALSE, identify.points=",
        response=="yes", ")", sep=""))
    }

anovaTable <- function(){
    if (!checkActiveModel()) return()
    if (!checkMethod("Anova", .activeModel)) return()
    doItAndPrint(paste("Anova(", .activeModel, ")", sep=""))
    }

VIF <- function(){
    if (!checkActiveModel()) return()
    if (!checkMethod("vif", .activeModel)) return()
    doItAndPrint(paste("vif(", .activeModel, ")", sep=""))
    }
            
influencePlot <- function(){
    if (!checkActiveModel()) return()
    if (!checkMethod("influence.plot", .activeModel)) return()
    response <- tclvalue(tkmessageBox(message="Identify points with mouse?", 
        icon="question", type="yesno", default="no"))
    labels <- if (response == "no") ", labels=FALSE" else ""
    doItAndPrint(paste("influence.plot(", .activeModel, labels, ")", sep=""))
    }  
    
effectPlots <- function(){
    if (!checkActiveModel()) return()
    if (!checkMethod("effect", .activeModel)) return()
    doItAndPrint('trellis.device(theme="col.whitebg")')
    command <- paste("plot(all.effects(", .activeModel, "), ask=FALSE)", sep="")
    justDoIt(command)
    logger(command)
    NULL
    }

addObservationStatistics <- function(){
    addVariable <- function(name, values){
        variable <- paste(.activeModel, ".", name, sep="")
        if (is.element(variable, .variables)) {
            ans <- checkReplace(variable)
            if (tclvalue(ans) == "no") return()
            }
        command <- paste(name, "(", .activeModel, ")", sep="")
        justDoIt(paste(.activeDataSet, "$", variable, " <- ", command, sep=""))
        logger(paste(.activeDataSet, "$", variable, " <- ", command, sep=""))
        }
    if (!checkActiveModel()) return()
    if (.modelWithSubset){
        tkmessageBox(message=
            paste("Observation statistics not available\nfor a model fit to a subset of the data."),
            icon="error", type="ok")
        tkfocus(.commander)
        return()
        }
    initializeDialog(title="Add Observation Statistics to Data")
    obsNumberExists <- is.element("obsNumber", .variables)
    checkBoxes(frame="selectFrame", boxes=c("fitted", "residuals", "rstudent", "hatvalues", "cookd", "obsNumbers"),
        initialValues=c("1", "1", "1", "1", "1", if(obsNumberExists) "0" else "1"),
        labels=c("Fitted values", "Residuals", "Studentized residuals", "Hat-values", "Cook's distances", 
        "Observation indices"))
    onOK <- function(){
        if (tclvalue(fittedVariable) == 1) {
            if (checkMethod("fitted", .activeModel, default=TRUE)) addVariable("fitted")
            }
        if (tclvalue(residualsVariable) == 1) {
            if (checkMethod("residuals", .activeModel, default=TRUE)) addVariable("residuals")
            }
        if (tclvalue(rstudentVariable) == 1) {
            if (checkMethod("rstudent", .activeModel)) addVariable("rstudent")
            }
        if (tclvalue(hatvaluesVariable) == 1) {
            if (checkMethod("hatvalues", .activeModel)) addVariable("hatvalues")
            }
        if (tclvalue(cookdVariable) == 1) {
            if (checkMethod("cooks.distance", .activeModel)) addVariable("cookd")
            }
        if (tclvalue(obsNumbersVariable) == 1){
            proceed <- if (obsNumberExists) tclvalue(checkReplace("obsNumber")) else "yes"
            if (proceed == "yes") {
                command <- paste(.activeDataSet, "$obsNumber <- 1:nrow(", .activeDataSet, ")", sep="")
                justDoIt(command)
                logger(command)
                }
            }
        activeDataSet(.activeDataSet, flushModel=FALSE)
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="influence.measures")
    tkgrid(selectFrame, sticky="w")  
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix(rows=5, columns=1)
    }

residualQQPlot <- function(){
    if (!checkActiveModel()) return()
    if (!checkMethod("qq.plot", .activeModel)) return()
    initializeDialog(title="Residual Quantile-Comparison Plot")
    selectFrame <- tkframe(top)
    simulateVar <- tclVar("1")
    identifyVar <- tclVar("0")
    simulateCheckBox <- tkcheckbutton(selectFrame, variable=simulateVar)
    identifyCheckBox <- tkcheckbutton(selectFrame, variable=identifyVar)
    onOK <- function(){
        tkdestroy(top)
        simulate <- tclvalue(simulateVar) == 1
        identify <- if (tclvalue(identifyVar) == 1) paste("names(residuals(", .activeModel, "))",
            sep="") else "FALSE"
        command <- paste("qq.plot(", .activeModel, ", simulate=", simulate, ", labels=", identify,
            ")", sep="")
        doItAndPrint(command)
        if (.grab.focus) tkgrab.release(top)
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="qq.plot.lm")
    tkgrid(tklabel(selectFrame, text="Simulated confidence envelope"), simulateCheckBox, sticky="w")
    tkgrid(tklabel(selectFrame, text="Identify points with mouse"), identifyCheckBox, sticky="w")
    tkgrid(selectFrame, sticky="w")  
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix(rows=2, columns=1)
    }

testLinearHypothesis <- function(){
    if (!checkActiveModel()) return()
    if (!checkMethod("linear.hypothesis", .activeModel)) return()
    env <- environment()
    initializeDialog(title="Test Linear Hypothesis")
    outerTableFrame <- tkframe(top)
    assign(".tableFrame", tkframe(outerTableFrame), envir=env)
    setUpTable <- function(...){
        tkdestroy(get(".tableFrame", envir=env))
        assign(".tableFrame", tkframe(outerTableFrame), envir=env)
        nrows <- as.numeric(tclvalue(rowsValue))
        col.names <- eval(parse(text=paste("names(coef(", .activeModel, "))")))
        col.names <- substring(paste(abbreviate(col.names, 12), "            "), 1, 12)
        make.col.names <- "tklabel(.tableFrame, text='')"
        for (j in 1:ncols) {
            make.col.names <- paste(make.col.names, ", ", 
                "tklabel(.tableFrame, text='", col.names[j], "')", sep="")
            }
        make.col.names <- paste(make.col.names, ", tklabel(.tableFrame, text='          ')",
            ", tklabel(.tableFrame, text='Right-hand side')", sep="")
        eval(parse(text=paste("tkgrid(", make.col.names, ")", sep="")), envir=env)
        for (i in 1:nrows){   
            varname <- paste(".tab.", i, ".1", sep="") 
            rhs.name <- paste(".rhs.", i, sep="")
            assign(varname, tclVar("0") , envir=env)
            assign(rhs.name, tclVar("0"), envir=env)
            make.row <- paste("tklabel(.tableFrame, text=", i, ")")
            make.row <- paste(make.row, ", ", "tkentry(.tableFrame, width='5', textvariable=", 
                varname, ")", sep="")
            for (j in 2:ncols){
                varname <- paste(".tab.", i, ".", j, sep="")
                assign(varname, tclVar("0"), envir=env)
                make.row <- paste(make.row, ", ", "tkentry(.tableFrame, width='5', textvariable=", 
                    varname, ")", sep="")
                }
            make.row <- paste(make.row, ", tklabel(.tableFrame, text='     '),",
                "tkentry(.tableFrame, width='5', textvariable=", rhs.name, ")", sep="")
            eval(parse(text=paste("tkgrid(", make.row, ")", sep="")), envir=env)
            }
        tkgrid(get(".tableFrame", envir=env), sticky="w")
        }
    ncols <- eval(parse(text=paste("length(coef(", .activeModel, "))")))
    rowsFrame <- tkframe(top)
    rowsValue <- tclVar("1")
    rowsSlider <- tkscale(rowsFrame, from=1, to=ncols, showvalue=FALSE, variable=rowsValue,
        resolution=1, orient="horizontal", command=setUpTable)
    rowsShow <- tklabel(rowsFrame, textvariable=rowsValue, width=2, justify="right")
    onOK <- function(){
        nrows <- as.numeric(tclvalue(rowsValue))
        cell <- 0
        values <- rep(NA, nrows*ncols)
        rhs <- rep(NA, nrows)
        for (i in 1:nrows){
            rhs.name <- paste(".rhs.", i, sep="")
            rhs[i] <- as.numeric(eval(parse(text=paste("tclvalue(", rhs.name,")", sep=""))))
            for (j in 1:ncols){
                cell <- cell+1
                varname <- paste(".tab.", i, ".", j, sep="")
                values[cell] <- as.numeric(eval(parse(text=paste("tclvalue(", varname,")", sep=""))))
                }
            }
        values <- na.omit(values)
        if (length(values) != nrows*ncols){
            tkmessageBox(message=paste("Number of valid entries in hypothesis matrix(", length(values), ")\n",
                "not equal to number of rows (", nrows,") * number of columns (", ncols,").", 
                sep=""), icon="error", type="ok")
            if (.grab.focus) tkgrab.release(top)
            tkdestroy(top)
            testLinearHypothesis()
            return()
            }
        if (qr(matrix(values, nrows, ncols, byrow=TRUE))$rank < nrows) {
            tkmessageBox(message="Hypothesis matrix is not of full row rank", 
                icon="error", type="ok")
            if (.grab.focus) tkgrab.release(top)
            tkdestroy(top)
            testLinearHypothesis()
            return()
            }            
        rhs <- na.omit(rhs)
        if (length(rhs) != nrows){
            errorCondition(recall=testLinearHypothesis, message=paste("Number of valid entries in rhs vector (", 
                length(rhs), ")\n", "not equal to number of rows (", nrows,")", sep=""))
            return()
            }
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        command <- paste("matrix(c(", paste(values, collapse=","), "), ", nrows, ", ", ncols,
            ", byrow=TRUE)", sep="")
        assign(".Hypothesis", justDoIt(command), envir=.GlobalEnv)
        logger(paste(".Hypothesis <- ", command, sep=""))
        command <- paste("c(", paste(rhs, collapse=","), ")", sep="")
        assign(".RHS", justDoIt(command), envir=.GlobalEnv)
        logger(paste(".RHS <- ", command, sep=""))
        command <- paste("linear.hypothesis(", .activeModel, ", .Hypothesis, rhs=.RHS)", sep="")
        doItAndPrint(command)
        justDoIt("remove(.Hypothesis, .RHS, envir=.GlobalEnv)") 
        logger("remove(.Hypothesis, .RHS)")                                              
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="linear.hypothesis")
    tkgrid(tklabel(rowsFrame, text="Number of Rows:"), rowsSlider, rowsShow, sticky="w")
    tkgrid(rowsFrame, sticky="w")
    tkgrid(tklabel(top, text="Enter hypothesis matrix and right-hand side vector:", fg="blue"), sticky="w")
    tkgrid(outerTableFrame, sticky="w")
    tkgrid(tklabel(top, text=""))
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix(rows=4, columns=1)       
    } 

compareModels <- function(){
    models <- listAllModels()
    if (length(models) < 2){
        tkmessageBox(message="There are fewer than two models.", 
                icon="error", type="ok")
        tkfocus(.commander)
        return()
        }
    initializeDialog(title="Compare Models")
    modelsBox1 <- variableListBox(top, models, title="First model (pick one)")
    modelsBox2 <- variableListBox(top, models, title="Second model (pick one)")
    onOK <- function(){
        model1 <- getSelection(modelsBox1)
        model2 <- getSelection(modelsBox2)
        if (length(model1) == 0 || length(model2) == 0) {
            errorCondition(recall=compareModels, message="You must select two models.")
            return()
            }
        if (!checkMethod("anova", model1)) {
            tkgrab.release(top)
            tkdestroy(top)            
            return()
            }
        if (!eval(parse(text=paste("class(", model1, ")[1] == class(", model2, ")[1]",
            sep="")), envir=.GlobalEnv)){
                tkmessageBox(message="Models are not of the same class.", 
                    icon="error", type="ok")
                tkgrab.release(top)
                tkdestroy(top)
                compareModels()
                return()
                }
        tkgrab.release(top)
        tkdestroy(top)
        doItAndPrint(paste("anova(", model1, ",", model2, ")", sep=""))
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="anova")
    tkgrid(getFrame(modelsBox1), getFrame(modelsBox2), sticky="nw")
    tkgrid(buttonsFrame, columnspan=2, sticky="w")
    dialogSuffix(rows=2, columns=2)
    }
    
BreuschPaganTest <- function(){
    if(!checkActiveModel()) return()
    if (!checkClass(.activeModel, "lm")) return()
    initializeDialog(title="Breusch-Pagan Test")
    tkgrid(tklabel(top, text="Score Test for Nonconstant Error Variance", fg="blue"), sticky="w")
    optionsFrame <- tkframe(top)
    onOK <- function(){
        var <- tclvalue(varVariable)
        type <- if (var == "fitted") paste(", varformula = ~ fitted.values(",
                    .activeModel, ")", sep="") 
                else if (var == "predictors") ""
                else paste(", varformula = ~", tclvalue(rhsVariable), sep="")
        student <- if (tclvalue(studentVariable) == 1) "TRUE" else "FALSE"
        model.formula <- as.character(eval(parse(text=paste("formula(", .activeModel, ")", sep=""))))
        model.formula <- paste(model.formula[2], "~", model.formula[3])
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        command <- paste("bptest(", model.formula, type, ", studentize=", student,
            ", data=", .activeDataSet, ")", sep="")
        doItAndPrint(command)  
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="bptest")
    studentVariable <- tclVar("0")
    studentFrame <- tkframe(optionsFrame)
    studentCheckBox <- tkcheckbutton(studentFrame, variable=studentVariable)
    tkgrid(tklabel(studentFrame, text="Studentized test statistic", justify="left"),
        studentCheckBox, sticky="w")
    tkgrid(studentFrame, sticky="w")
    radioButtons(optionsFrame, name="var", buttons=c("fitted", "predictors", "other"), 
        labels=c("Fitted values", "Explanatory variables", "Other (specify)"), title="Variance Formula")
    tkgrid(varFrame, sticky="w")
    modelFormula(optionsFrame, hasLhs=FALSE)
    tkgrid(formulaFrame, sticky="w")
    tkgrid(outerOperatorsFrame)
    tkgrid(getFrame(xBox), sticky="w")
    tkgrid(optionsFrame, sticky="w")
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix(rows=4, columns=1)
    }

DurbinWatsonTest <- function(){
    if (!checkActiveModel()) return()
    if (!checkClass(.activeModel, "lm")) return()
    initializeDialog(title="Durbin-Waton Test")
    tkgrid(tklabel(top, text="Test for First-Order Error Autocorrelation", fg="blue"), sticky="w")
    onOK <- function(){
        altHypothesis <- tclvalue(altHypothesisVariable)
        model.formula <- as.character(eval(parse(text=paste("formula(", .activeModel, ")", sep=""))))
        model.formula <- paste(model.formula[2], "~", model.formula[3])
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        command <- paste("dwtest(", model.formula, ', alternative="', altHypothesis,
             '", data=', .activeDataSet, ')', sep="")
        doItAndPrint(command)  
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="dwtest")
    radioButtons(name="altHypothesis", buttons=c("greater", "notequal", "less"), values=c("greater", "two.sided", "less"),
        labels=c("rho >  0", "rho != 0", "rho <  0"), title="Alternative Hypothesis")
    tkgrid(altHypothesisFrame, sticky="w")
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix(rows=3, columns=1)
    }

RESETtest <- function(){
    if(!checkActiveModel()) return()
    if (!checkClass(.activeModel, "lm")) return()
    initializeDialog(title="RESET Test")
    tkgrid(tklabel(top, text="Test for Nonlinearity", fg="blue"), sticky="w")
    onOK <- function(){
        type <- tclvalue(typeVariable)
        square <- tclvalue(squareVariable)
        cube <- tclvalue(cubeVariable)
        model.formula <- as.character(eval(parse(text=paste("formula(", .activeModel, ")", sep=""))))
        model.formula <- paste(model.formula[2], "~", model.formula[3])
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        if (square == "0" && cube == "0"){
            errorCondition(recall=RESETtest, message="No powers are checked.")
            return()
            }
        powers <- if (square == "1" && cube == "1") "2:3"
            else if (square == "1" && cube == "0") "2"
            else if (square == "0" && cube == "1") "3"
        command <- paste("reset(", model.formula, ", power=", powers,
            ', type="', type, '", data=', .activeDataSet, ')', sep="")
        doItAndPrint(command)  
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="reset")
    optionsFrame <- tkframe(top)
    squareVariable <- tclVar("1")
    squareCheckBox <- tkcheckbutton(optionsFrame, variable=squareVariable)
    cubeVariable <- tclVar("1")
    cubeCheckBox <- tkcheckbutton(optionsFrame, variable=cubeVariable)
    typeVariable <- tclVar("regressor")
    radioButtons(optionsFrame, name="type", buttons=c("regressor", "fitted", "princomp"),
        labels=c("Explanatory variables", "Fitted values", "First principal component"),
        title="Type of Test")
    tkgrid(tklabel(optionsFrame, text="Powers to Include", fg="blue"), sticky="w")
    tkgrid(tklabel(optionsFrame, text="2 (squares)"), squareCheckBox, sticky="w")
    tkgrid(tklabel(optionsFrame, text="3 (cubes)   "), cubeCheckBox, sticky="w")
    tkgrid(typeFrame, sticky="w")
    tkgrid(optionsFrame, sticky="w")
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix(rows=3, columns=1)
    }

outlierTest <- function(){
    if (!checkActiveModel()) return()
    if (!checkMethod("outlier.test", .activeModel)) return()
    doItAndPrint(paste("outlier.test(", .activeModel, ")", sep=""))
    }
# SciViews specific R Commander code

# last modified 24 October 2004 by Ph. Grosjean
#  small fix to call to list.files() by J. Fox 17 Jan 05

is.SciViews <- function() {
    # SciViews defines the option "SciViews.version".
    # So, we test if we are in SciViews this way:
    res <- !is.null(getOption("SciViews.version"))
    res
    }
    
is.SciViews.TclTk <- function() {
    # Determine if a TclTk-communicating SciViews client is currently running
    res <- (!is.null(getOption("SciViews.TclTk")) && getOption("SciViews.TclTk") == TRUE)
    res
    }
    
tkfocus <- function(...){
    # A call to tcltk:::tkfocus() causes a GPF in SciViews
    # => replaced by this version that check if we are in SciViews or not
    if (!is.SciViews()) tcltk:::tkfocus(...)
    }

svCommander <- function(){
    # The SciViews specific Commander() function
    if (is.SciViews()) {
        ### TO DO: automatically generate the menu from "Rcmdr-menus.txt"
        # Display the R commander menu
        #...
        setOption <- function(option, default, global=TRUE) {
            opt <- if (is.null(current[[option]])) default else current[[option]]
            if (global) assign(paste(".", option, sep=""), opt, envir=.GlobalEnv)
            else opt
            }
        etc <- file.path(.path.package(package="Rcmdr")[1], "etc")
        # Do NOT sink error messages!
        #assign(".messages.connection", textConnection(".messages", open = "w"), envir=.GlobalEnv)
        #sink(.messages.connection, type="message")
        assign(".length.messages", 0, envir=.GlobalEnv)
        assign(".activeDataSet", NULL, envir=.GlobalEnv)
        assign(".activeModel", NULL, envir=.GlobalEnv)
        assign(".logFileName", NULL, envir=.GlobalEnv)
        assign(".outputFileName", NULL, envir=.GlobalEnv)
        assign(".modelNumber", 0, envir=.GlobalEnv)
        assign(".rgl", FALSE, envir=.GlobalEnv)
        current <- options("Rcmdr")[[1]]
        setOption("log.font.size", 10)
        assign(".logFont", tkfont.create(family="courier", size=.log.font.size), envir=.GlobalEnv)
        assign(".operatorFont", tkfont.create(family="courier", size=.log.font.size),
            envir=.GlobalEnv)
        scale.factor <- current$scale.factor
        if (!is.null(scale.factor)) .Tcl(paste("tk scaling ", scale.factor, sep=""))
        setOption("contrasts", c("contr.Treatment", "contr.poly"))
        setOption("log.commands", TRUE)
        assign(".logCommands", if (.log.commands) tclVar("1") else tclVar("0"), envir=.GlobalEnv)
        setOption("console.output", TRUE) # Must be set to TRUE for SciViews app!
        log.height <- as.character(setOption("log.height", if (!.log.commands) 0 else 10, global=FALSE))
        log.width <- as.character(setOption("log.width", 80, global=FALSE))
        output.height <- as.character(setOption("output.height",
            if (.console.output) 0
            else if ((as.numeric(log.height) != 0) || (!.log.commands)) 2*as.numeric(log.height)
            else 20, global=FALSE))
        setOption("output.height", output.height)
        assign(".saveOptions", options(warn=1, contrasts=.contrasts, width=as.numeric(log.width),
            na.action="na.exclude", graphics.record=TRUE), envir=.GlobalEnv)
        setOption("double.click", FALSE)
        setOption("sort.names", TRUE)
        setOption("grab.focus", TRUE)
        setOption("attach.data.set", TRUE)
        setOption("log.text.color", "black")
        setOption("command.text.color", "red")
        setOption("output.text.color", "darkblue")
        setOption("multiple.select.mode", "extended")
        if (.Platform$OS.type != "windows") {
            assign(".oldPager", options(pager=RcmdrPager), envir=.GlobalEnv)
            default.font.size <- as.character(setOption("default.font.size", 10, global=FALSE))
            default.font <- setOption("default.font",
                paste("*helvetica-medium-r-normal-*-", default.font.size, "*", sep=""), global=FALSE)
            .Tcl(paste("option add *font ", default.font, sep=""))
            }
        placement <- setOption("placement", "-40+40", global=FALSE)
#        source.files <- list.files(etc, pattern="\\.R$")  # duplicate line commented out by J. Fox
        .commander.done <<- tclVar("0") # to address problem in Debian Linux
        source.files <- list.files(etc, pattern="\\.[Rr]$")
        for (file in source.files) {
             source(file.path(etc, file))
             cat(paste("Sourced:", file, "\n"))
             }
        Menus <- read.table(file.path(etc, "Rcmdr-menus.txt"), as.is=TRUE)
        ### TO DO: we need another treatment for this!
        #for (m in 1:nrow(Menus)){
        #    if (Menus[m, 1] == "menu") assign(Menus[m, 2], tkmenu(eval(parse(text=Menus[m, 3])), tearoff=FALSE))
        #    else if (Menus[m, 1] == "item") {
        #         if (Menus[m, 3] == "command")
        #             tkadd(eval(parse(text=Menus[m, 2])),"command", label=Menus[m, 4], command=eval(parse(text=Menus[m, 5])))
        #         else if (Menus[m, 3] == "cascade")
        #             tkadd(eval(parse(text=Menus[m, 2])),"cascade", label=Menus[m, 4], menu=eval(parse(text=Menus[m, 5])))
        #         else stop(paste("menu defintion error:", Menus[m, ], collapse=" "))
        #         }
        #    else stop(paste("menu defintion error:", Menus[m, ], collapse=" "))
        #    }
        exceptions <- scan(file.path(etc, "log-exceptions.txt"), what="", quiet=TRUE, comment.char="#")
        assign(".dataSetName", tclVar("<No active dataset>"), envir=.GlobalEnv)
        assign(".modelName", tclVar("<No active model>"), envir=.GlobalEnv)
        show.edit.button <- options("Rcmdr")[[1]]$show.edit.button
        show.edit.button <- if (is.null(show.edit.button)) TRUE else show.edit.button
        }
    }

svlogger <- function(command){
    # the SciViews specific logger() function
    if (is.SciViews()) {
        # Behaviour is different if it is a TclTk communicating client,
        # or a plug
        if (is.SciViews.TclTk()) { # TclTk SciViews client
            # getTemp from SciViews[svMisc] is redefined here to avoid a Depends: svMisc!
            getTemp <- function(x, default = NULL, mode="any") {
                if  (exists(x, envir = TempEnv(), mode = mode, inherits = FALSE)) {
                    return(get(x, envir = TempEnv(), mode = mode, inherits = FALSE))
                } else { # Variable not found, return the default value
                    return(default)
                }
            }
            if (tclvalue(.logCommands) == "1") {
                CmdFun <- getTemp(".guiCmd", mode = "function")
                if (!is.null(CmdFun)) CmdFun(paste("Log\n", command))
            }
            lines <- strsplit(command, "\n")[[1]]
            for (line in lines) cat(paste("\n Rcmdr ", line, "\n"))
            command
        } else {    # plug SciViews client
            lines <- strsplit(command, "\n")[[1]]
            for (line in lines) {
                cat(paste("History", line, "\n ", line, "    #[R-cmdr]\n", sep=""))
                if (tclvalue(.logCommands) == "1") cat(paste("Script", command, "\n", sep=""))
                }
            command
            }
        }
    }

activeDataSetEdit <- function() {
    # This is SciViews equivalent to onEdit function of Commander()
    if (activeDataSet() == FALSE)
        return()
    command <- paste("fix(", .activeDataSet, ")", sep="")
    justDoIt(command)
    svlogger(command)
    activeDataSet(.activeDataSet)
    invisible()
}

activeDataSetView <- function() {
    # This is SciViews equivalent to onView function of Commander()
    if (activeDataSet() == FALSE)
        return()
    view.height <- 30 #max(as.numeric(output.height) + as.numeric(log.height), 10)
    command <- paste("showData(", .activeDataSet, ", placement='-20+200', font=.logFont, maxwidth=", 
    80, ", maxheight=", view.height, ")", sep="")
    justDoIt(command)
    invisible(svlogger(command))
    }

optionLogCommand <- function() {
    # Change log option in SciViews
    response <- tclvalue(tkmessageBox(message="Log R-cmdr commands in a script?",
        icon="question", type="yesno", default="yes"))
    val <- if (response == "yes") tclVar("1") else tclVar("0")
    assign(".logCommands", val, envir=.GlobalEnv)
    val <- if (response == "yes") TRUE else FALSE
    assign(".log.commands", val, envir=.GlobalEnv)
    Opts <- options("Rcmdr")[[1]]
    Opts$log.commands <- val
    options(Rcmdr=Opts)
    refreshStatus()
}

optionAttachDataSet <- function() {
    # Change attach option in SciViews
    response <- tclvalue(tkmessageBox(message="Attach active data set?",
        icon="question", type="yesno", default="yes"))
    val <- if (response == "yes") TRUE else FALSE
    assign(".attach.data.set", val, envir=.GlobalEnv)
    Opts <- options("Rcmdr")[[1]]
    Opts$attach.data.set <- val
    options(Rcmdr=Opts)
    refreshStatus()
}

optionSortVariables <- function() {
    # Change sort variable names option
    response <- tclvalue(tkmessageBox(message="Sort variable names alphabetically?",
        icon="question", type="yesno", default="yes"))
    val <- if (response == "yes") TRUE else FALSE
    assign(".sort.names", val, envir=.GlobalEnv)
    Opts <- options("Rcmdr")[[1]]
    Opts$sort.names <- val
    options(Rcmdr=Opts)
    refreshStatus()
}

refreshStatus <- function() {
    # Refresh dataset and model indication in the status bar of SciViews Client
    DataSet <- get(".activeDataSet", pos = .GlobalEnv)
    if (is.null(DataSet) || length(DataSet) == 0) DataSet <- "<no data>"
    Model <- get(".activeModel", pos = .GlobalEnv)
    if (is.null(Model) || length(Model) == 0) Model <- "<no model>"
    if (get(".log.commands", pos = .GlobalEnv)) Opts <- " [log]" else Opts <- " "
    if (get(".attach.data.set", pos = .GlobalEnv)) Opts <- paste(Opts, "[attach]", sep="")
    if (get(".sort.names", pos = .GlobalEnv)) Opts <- paste(Opts, "[sort]", sep="")
    # If it is a "SciViews TclTk GUI" client, use it...
    if (is.SciViews.TclTk()) {
        cat(paste("Data: ", DataSet, ", Model: ", Model, Opts, sep=""), file = file.path(tempdir(), "svStatus.txt"))
        # getTemp from SciViews[svMisc] is redefined here to avoid a Depends: svMisc!
        getTemp <- function(x, default = NULL, mode="any") {
            if  (exists(x, envir = TempEnv(), mode = mode, inherits = FALSE)) {
                return(get(x, envir = TempEnv(), mode = mode, inherits = FALSE))
            } else { # Variable not found, return the default value
                return(default)
            }
        }
        CmdFun <- getTemp(".guiCmd", mode = "function")
        if (!is.null(CmdFun)) CmdFun("Status")
        # Possibly update data in the object browser
        if (exists(".guiObjCallback", envir = TempEnv(), inherits = FALSE)) getTemp(".guiObjCallback")()
    } else {    # This should be SciViews Insider, or other similar client
        cat("StatusTextData: ", DataSet, ", Model: ", Model, Opts, "", sep="")
    }
}
# last modified 13 Dec 04 by J. Fox

.onAttach <- function(...){
    cat("\nRcmdr Version 0.9-17\n")
    Commander()
    }

.onLoad <- function(...){
    save.options <- options(warn=-1)
    on.exit(options(save.options))
    tcltk <- require(tcltk)
    required.packages <- rev(c("abind", "car", "effects", "foreign", "lattice", "lmtest", "MASS", 
        "mgcv", "multcomp", "mvtnorm", "nlme", "nnet", "relimp", "sandwich", "strucchange", "zoo"))
    for (package in required.packages) assign(package, require(package, character.only=TRUE))
    if (!tcltk) stop("The tcltk package is absent. The R Commander cannot function.")
    assign(".rglPackage", require("rgl", character.only=TRUE), envir=.GlobalEnv)
    if (!.rglPackage) cat("\n\nrgl package is missing; 3D graphs not available.\n\n")
    absent <- !sapply(required.packages, function(package) eval(parse(text=package)))
    missing.packages <- required.packages[absent]
    if (any(absent)) {
        response <- tkmessageBox(message=paste("The following packages required by Rcmdr are missing:\n",
                            paste(missing.packages, collapse=", "), "\nInstall these packages?"), 
                        icon="error", type="yesno")
        if (as.character(response) == "yes") {
            top <- tktoplevel(borderwidth=10)
            tkwm.title(top, "Install Missing Packages")
            locationFrame <- tkframe(top)
            locationVariable <- tclVar("CRAN")
            CRANbutton <- tkradiobutton(locationFrame, variable=locationVariable, value="CRAN")
#         Note: Bioconductor code not currently necessary
#            BioconductorButton <- tkradiobutton(locationFrame, variable=locationVariable, value="Bioconductor")
            localButton <- tkradiobutton(locationFrame, variable=locationVariable, value="local")
            directoryVariable <- tclVar("")
            directoryFrame <- tkframe(locationFrame)
            onBrowse <- function(){
                tclvalue(directoryVariable) <- tclvalue(tkchooseDirectory())
                }
            browseButton <- tkbutton(directoryFrame, text="Browse...", width="12", command=onBrowse, borderwidth=3)
            locationField <- tkentry(directoryFrame, width="20", textvariable=directoryVariable)
            locationScroll <- tkscrollbar(directoryFrame, orient="horizontal",
                repeatinterval=5, command=function(...) tkxview(locationField, ...))
            tkconfigure(locationField, xscrollcommand=function(...) tkset(locationScroll, ...))
            tkgrid(tklabel(top, text="Install Packages From:", fg="blue"), sticky="nw")
            tkgrid(tklabel(directoryFrame, text="Specify package  \ndirectory:", justify="left"), 
                locationField, sticky="w")
            tkgrid(browseButton, locationScroll, sticky="w")
            tkgrid(locationScroll, sticky="ew")
            tkgrid(tklabel(locationFrame, text="CRAN"), CRANbutton, sticky="w")
#            tkgrid(tklabel(locationFrame, text="Bioconductor"), BioconductorButton, sticky="w")
            tkgrid(tklabel(locationFrame, text="Local package directory\n(must include PACKAGES index file)", 
                justify="left"), localButton, directoryFrame, sticky="nw")
            tkgrid(locationFrame, sticky="w")
            tkgrid(tklabel(top, text=""))
            onOK <- function(){
                errorMessage <- function() tkmessageBox(message=paste(
                    "The following packages were not found at the specified location:\n",
                    paste(missing.packages[!present], collapse=", ")),  icon="error", type="ok")
                tkgrab.release(top)
                tkdestroy(top)
                location <- tclvalue(locationVariable)
                if (location == "CRAN") {
                    packages <- utils:::CRAN.packages()[,1]
                    present <- missing.packages %in% packages
                    if (!all(present)){
                        errorMessage()
                        stop("Missing packages.", call.=FALSE)
                        }
                    utils:::install.packages(missing.packages, lib=.libPaths()[1])
                    }
#                else if (location == "Bioconductor") {
#                    packages <- CRAN.packages(CRAN=getOption("BIOC"))[,1]
#                    present <- missing.packages %in% packages
#                    if (!all(present)){
#                        errorMessage()
#                        stop("Missing packages.", call.=FALSE)
#                        }
#                    install.packages(missing.packages., lib=.libPaths()[1],
#                        CRAN=getOption("BIOC"))
#                    }
                else {
                    directory <- paste("file:", tclvalue(directoryVariable), sep="")
                    packages <- utils:::CRAN.packages(contriburl=directory)[,1]
                    present <- missing.packages %in% packages
                    if (!all(present)){
                        errorMessage()
                        stop("Missing packages.", call.=FALSE)
                        }
                    utils:::install.packages(missing.packages, contriburl=directory, lib=.libPaths()[1])
                    }
                for (package in missing.packages) require(package, character.only=TRUE)
                }
            onCancel <- function(){
                tkgrab.release(top)
                tkdestroy(top)
                stop("Missing packages.", call.=FALSE)
                }
            onHelp <- function() help("install.packages")
            buttonsFrame <- tkframe(top)
            OKbutton <- tkbutton(buttonsFrame, text="OK", fg="darkgreen", width="12", command=onOK, default="active",
                    borderwidth=3)
            cancelButton <- tkbutton(buttonsFrame, text="Cancel", fg="red", width="12", command=onCancel,
                    borderwidth=3)
            helpButton <- tkbutton(buttonsFrame, text="Help", width="12", command=onHelp, borderwidth=3)
            tkgrid(OKbutton, tklabel(buttonsFrame, text="  "), cancelButton, tklabel(buttonsFrame, text="            "), 
                helpButton, sticky="w")
            tkgrid(buttonsFrame, sticky="w")
            for (row in 0:2) tkgrid.rowconfigure(top, row, weight=0)
            tkgrid.columnconfigure(top, 0, weight=0)
            .Tcl("update idletasks")
            tkwm.resizable(top, 0, 0)
            tkbind(top, "<Return>", onOK)
            tkwm.deiconify(top)
            tkgrab.set(top)
            tkfocus(top)
            tkwait.window(top)
            }
        else stop("Missing packages: ", paste(missing.packages, collapse=", "), call.=FALSE)
        }           
    }
# Statistics Menu dialogs

# last modified 3 Jan 05 by J. Fox

    # Dimensional-analysis menu
    
Reliability <- function(){
    if(!checkActiveDataSet()) return()
    if (!checkNumeric(3)) return()
    initializeDialog(title="Scale Reliability")
    xBox <- variableListBox(top, .numeric, selectmode="multiple", title="Variables (pick three or more)")
    onOK <- function(){
        x <- getSelection(xBox)
        if (3 > length(x)) {
            errorCondition(recall=Reliability, message="Fewer than 3 variables selected.")
            return()
            }
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        x <- paste('"', x, '"', sep="")
        doItAndPrint(paste("reliability(cov(", .activeDataSet, "[,c(", paste(x, collapse=","),
            ')], use="complete.obs"))', sep=""))
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="reliability")
    tkgrid(getFrame(xBox), sticky="nw")
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix(rows=2, columns=1)
    }

principalComponents <- function(){
    if(!checkActiveDataSet()) return()
    if(!checkNumeric(2)) return()
    initializeDialog(title="Principal Components Analysis")
    xBox <- variableListBox(top, .numeric, selectmode="multiple", title="Variables (pick two or more)")
    subsetBox()
    checkBoxes(frame="optionsFrame", boxes=c("correlations", "screeplot", "addPC"), initialValues=c("1", "0", "0"),
        labels=c("Analyze correlation matrix", "Screeplot", "Add principal components to data set"))
    onOK <- function(){
        x <- getSelection(xBox)
        nvar <- length(x)
        correlations <- tclvalue(correlationsVariable)
        subset <- tclvalue(subsetVariable)
        screeplot <- tclvalue(screeplotVariable)
        addPC <- tclvalue(addPCVariable)
        if (2 > length(x)) {
            errorCondition(recall=principalComponents, message="Fewer than 2 variables selected.")
            return()
            }
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        subset <- if (trim.blanks(subset) == "<all valid cases>") "" else paste(", subset=", subset, sep="")
        correlations <- if (correlations == "1") "TRUE" else "FALSE"
        command <- paste("princomp(~", paste(x, collapse="+"), ", cor=", correlations,
            ", data=", .activeDataSet, subset, ")", sep="")
        assign(".PC", justDoIt(command), envir=.GlobalEnv)
        logger(paste(".PC <- ", command, sep=""))
        doItAndPrint("unclass(loadings(.PC))  # component loadings")
        doItAndPrint(".PC$sd^2  # component variances")
        if (screeplot == "1") {
            justDoIt("screeplot(.PC)")
            logger("screeplot(.PC)")
            }
        if (addPC == "1") {
            initializeDialog(subdialog, title="Number of Components")
            tkgrid(tklabel(subdialog, text="Number of components to retain:", fg="blue"), sticky="w")    
            sliderFrame <- tkframe(subdialog)
            sliderValue <- tclVar("1")
            componentsSlider <- tkscale(sliderFrame, from=1, to=nvar, showvalue=FALSE, variable=sliderValue,
                resolution=1, orient="horizontal")
            componentsShow <- tklabel(sliderFrame, textvariable=sliderValue, width=2, justify="right")
            onOKsub <- function() {
                if (.grab.focus) tkgrab.release(subdialog)
                tkdestroy(subdialog)
                assign(".ncomponents", as.numeric(tclvalue(sliderValue)), envir=.GlobalEnv)
                    }
            subOKCancelHelp()
            tkgrid(componentsSlider, componentsShow, sticky="nw")
            tkgrid(sliderFrame, sticky="w")
            tkgrid(subButtonsFrame, sticky="w")
            dialogSuffix(subdialog, onOK=onOKsub, rows=2, columns=1, focus=subdialog)
            if (exists(".ncomponents", envir=.GlobalEnv)){
                for(i in 1:.ncomponents){
                    var <- paste("PC", i, sep="")
                    if (is.element(var, .variables)) {
                        if ("no" == tclvalue(checkReplace(var))) next
                        }
                    justDoIt(paste(.activeDataSet, "$PC", i, " <- .PC$scores[,", i, "]", sep=""))
                    logger(paste(.activeDataSet, "$PC", i, " <- .PC$scores[,", i, "]", sep=""))
                    }
                activeDataSet(.activeDataSet)
                remove(.ncomponents, envir=.GlobalEnv)
                }
            }
        remove(.PC, envir=.GlobalEnv)   
        logger("remove(.PC)")
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="princomp")
    tkgrid(getFrame(xBox), sticky="nw")
    tkgrid(subsetFrame, sticky="w")
    tkgrid(optionsFrame, sticky="w")
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix(rows=4, columns=1)
    }

factorAnalysis <- function(){
    if(!checkActiveDataSet()) return()
    if(!checkNumeric(3)) return()
    initializeDialog(title="Factor Analysis")
    xBox <- variableListBox(top, .numeric, selectmode="multiple", title="Variables (pick three or more)")
    subsetBox()
    optionsFrame <- tkframe(top)
    checkFrame <- tkframe(top)
    radioButtons(checkFrame, name="rotation", buttons=c("noRotate", "varimax", "promax"), 
        values=c("none", "varimax", "promax"), initialValue="varimax", labels=c("None", "Varimax", "Promax"),
        title="Factor Rotation")
    radioButtons(checkFrame, name="scores", buttons=c("noScores", "bartlett", "regression"),
        values=c("none", "Bartlett", "regression"), labels=c("None", "Bartlett's method", "Regression method"),
        title="Factor Scores")
    onOK <- function(){
        x <- getSelection(xBox)
        nvar <- length(x)
        subset <- tclvalue(subsetVariable)
        rotation <- tclvalue(rotationVariable)
        scores <- tclvalue(scoresVariable)
        if (3 > length(x)) {
            errorCondition(recall=factorAnalysis, message="Fewer than 3 variables selected.")
            return()
            }
        f <- function(k, p) ((p - k)^2 - p - k)^2
        max.factors <- floor(optimize(f, c(0, nvar), tol=.0001, p=nvar)$minimum)
        initializeDialog(subdialog, title="Number of Factors")
        tkgrid(tklabel(subdialog, text="Number of factors to extract:", fg="blue"), sticky="w")    
        sliderFrame <- tkframe(subdialog)
        sliderValue <- tclVar("1")
        componentsSlider <- tkscale(sliderFrame, from=1, to=max.factors, showvalue=FALSE, variable=sliderValue,
            resolution=1, orient="horizontal")
        componentsShow <- tklabel(sliderFrame, textvariable=sliderValue, width=2, justify="right")
        onOKsub <- function() {
            if (.grab.focus) tkgrab.release(subdialog)
            tkdestroy(subdialog)
            assign(".nfactors", as.numeric(tclvalue(sliderValue)), envir=.GlobalEnv)
                }
        subOKCancelHelp()
        tkgrid(componentsSlider, componentsShow, sticky="nw")
        tkgrid(sliderFrame, sticky="w")
        tkgrid(subButtonsFrame, sticky="w")
        dialogSuffix(subdialog, onOK=onOKsub, rows=2, columns=1, focus=subdialog)
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        if (!exists(".nfactors", envir=.GlobalEnv)){
            tkfocus(.commander)
            return()
            }
        subset <- if (trim.blanks(subset) == "<all valid cases>") "" else paste(", subset=", subset, sep="")
        command <- paste("factanal(~", paste(x, collapse="+"), ", factors=", .nfactors, ', rotation="', rotation,
            '", scores="', scores, '", data=', .activeDataSet, subset, ")", sep="")
        assign(".FA", justDoIt(command), envir=.GlobalEnv)
        logger(paste(".FA <- ", command, sep=""))
        doItAndPrint(".FA")
        if (scores != "none") {
            for(i in 1:nfactor){
                var <- paste("F", i, sep="")
                if (is.element(var, .variables)) {
                    if ("no" == tclvalue(checkReplace(var))) next
                    }
                justDoIt(paste(.activeDataSet, "$F", i, " <- .FA$scores[,", i, "]", sep=""))
                logger(paste(.activeDataSet, "$F", i, " <- .FA$scores[,", i, "]", sep=""))
                }
            activeDataSet(.activeDataSet)
            }
        logger("remove(.FA)")
        remove(.FA, .nfactors, envir=.GlobalEnv)
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="factanal")
    tkgrid(getFrame(xBox), sticky="nw")
    tkgrid(subsetFrame, sticky="w")
    tkgrid(optionsFrame, sticky="w")
    tkgrid(rotationFrame, tklabel(checkFrame, text="    "), scoresFrame, sticky="w")
    tkgrid(checkFrame, sticky="w")
    tkgrid(buttonsFrame,  sticky="w")
    dialogSuffix(rows=5, columns=1)
    }
# Statistics Menu dialogs

# last modified 10 July 04 by J. Fox

    # Means menu

independentSamplesTTest <- function(){
    if (!checkActiveDataSet()) return()
    if (!checkNumeric()) return()
    if (!checkTwoLevelFactors()) return()
    initializeDialog(title="Independent Samples t-Test")
    variablesFrame <- tkframe(top)
    groupBox <- variableListBox(variablesFrame, .twoLevelFactors, title="Groups (pick one)")
    responseBox <- variableListBox(variablesFrame, .numeric, title="Response Variable (pick one)")
    onOK <- function(){
        group <- getSelection(groupBox)
        if (length(group) == 0) {
            errorCondition(recall=independentSamplesTTest, message="You must select a groups variable.")
            return()
            }
        response <- getSelection(responseBox)
        if (length(response) == 0) {
            errorCondition(recall=independentSamplesTTest, message="You must select a response variable.")
            return()
            }
        alternative <- as.character(tclvalue(alternativeVariable))
        level <- tclvalue(confidenceLevel)
        variances <- as.character(tclvalue(variancesVariable))
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        doItAndPrint(paste("t.test(", response, "~", group,
            ", alternative='", alternative, "', conf.level=", level,
            ", var.equal=", variances,
            ", data=", .activeDataSet, ")", sep=""))
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="t.test")
    optionsFrame <- tkframe(top)
    radioButtons(optionsFrame, name="alternative", buttons=c("twosided", "less", "greater"), values=c("two.sided", "less", "greater"),
        labels=c("Two-sided", "Difference < 0", "Difference > 0"), title="Alternative Hypothesis")
    confidenceFrame <- tkframe(optionsFrame)
    confidenceLevel <- tclVar(".95")
    confidenceField <- tkentry(confidenceFrame, width="6", textvariable=confidenceLevel)
    radioButtons(optionsFrame, name="variances", buttons=c("yes", "no"), values=c("TRUE", "FALSE"), initialValue="FALSE",
        labels=c("Yes", "No"), title="Assume equal variances?")
    tkgrid(getFrame(groupBox), tklabel(variablesFrame, text="    "), getFrame(responseBox), sticky="nw")
    tkgrid(variablesFrame, sticky="nw")
    tkgrid(tklabel(confidenceFrame, text="Confidence Level", fg="blue"),sticky="w")
    tkgrid(confidenceField, sticky="w")
    groupsLabel(groupsBox=groupBox)
    tkgrid(alternativeFrame, tklabel(optionsFrame, text="    "), confidenceFrame, tklabel(optionsFrame, text="    "),
        variancesFrame, sticky="nw")
    tkgrid(optionsFrame, sticky="nw")
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix(rows=4, columns=1)
    }

pairedTTest <- function(){
    if (!checkActiveDataSet()) return()
    if (!checkNumeric(2)) return()
    initializeDialog(title="Paired t-Test")
    xBox <- variableListBox(top, .numeric, title="First variable (pick one)")
    yBox <- variableListBox(top, .numeric, title="Second variable (pick one)")
    onOK <- function(){
        x <- getSelection(xBox)
        y <- getSelection(yBox)
        if (length(x) == 0 | length(y) == 0){
            errorCondition(recall=pairedTTest, message="You must select two variables.")
            return()
            }
        if (x == y){
            errorCondition(recall=pairedTTest, message="Variables must be different.")
            return()
            }
        alternative <- as.character(tclvalue(alternativeVariable))
        level <- tclvalue(confidenceLevel)
        tkdestroy(top)
        doItAndPrint(paste("t.test(", .activeDataSet, "$", x, ", ", 
            .activeDataSet, "$", y,
            ", alternative='", alternative, "', conf.level=", level, 
            ", paired=TRUE)", sep=""))
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="t.test")
    radioButtons(top, name="alternative", buttons=c("twosided", "less", "greater"), values=c("two.sided", "less", "greater"),
        labels=c("Two-sided", "Difference < 0", "Difference > 0"), title="Alternative Hypothesis")
    confidenceFrame <- tkframe(top)
    confidenceLevel <- tclVar(".95")
    confidenceField <- tkentry(confidenceFrame, width="6", textvariable=confidenceLevel)
    tkgrid(getFrame(xBox), getFrame(yBox), sticky="nw")    
    tkgrid(tklabel(confidenceFrame, text="Confidence Level", fg="blue"))
    tkgrid(confidenceField, sticky="w")
    tkgrid(alternativeFrame, confidenceFrame, sticky="nw")
    tkgrid(buttonsFrame, columnspan=2, sticky="w")
    dialogSuffix(rows=3, columns=2)
    }

singleSampleTTest <- function(){
    if (!checkActiveDataSet()) return()
    if (!checkNumeric()) return()
    initializeDialog(title="Single-Sample t-Test")
    xBox <- variableListBox(top, .numeric, title="Variable (pick one)")
    onOK <- function(){
        x <- getSelection(xBox)
        if (length(x) == 0){
            errorCondition(recall=singleSampleTTest, message="You must select a variable.")
            return()
            }
        alternative <- as.character(tclvalue(alternativeVariable))
        level <- tclvalue(confidenceLevel)
        mu <- tclvalue(muVariable)
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        doItAndPrint(paste("t.test(", .activeDataSet, "$", x,
            ", alternative='", alternative, "', mu=", mu, ", conf.level=", level, 
            ")", sep=""))
        tkdestroy(top)
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="t.test")
    radioButtons(top, name="alternative", buttons=c("twosided", "less", "greater"), values=c("two.sided", "less", "greater"),
        labels=c("Population mean = mu0", "Population mean < mu0", text="Population mean > mu0"), 
        title="Alternative Hypothesis")
    rightFrame <- tkframe(top)
    confidenceFrame <- tkframe(rightFrame)
    confidenceLevel <- tclVar(".95")
    confidenceField <- tkentry(confidenceFrame, width="6", textvariable=confidenceLevel)
    muFrame <- tkframe(rightFrame)
    muVariable <- tclVar("0.0")
    muField <- tkentry(muFrame, width="8", textvariable=muVariable)
    tkgrid(getFrame(xBox), sticky="nw") 
    tkgrid(tklabel(rightFrame, text=""), sticky="w")   
    tkgrid(tklabel(muFrame, text="Null hypothesis: mu = "), muField, sticky="w")
    tkgrid(muFrame, sticky="w")
    tkgrid(tklabel(confidenceFrame, text="Confidence Level: "), confidenceField, sticky="w")
    tkgrid(confidenceFrame, sticky="w")
    tkgrid(alternativeFrame, rightFrame, sticky="nw")
    tkgrid(buttonsFrame, columnspan=2, sticky="w")
    tkgrid.configure(confidenceField, sticky="e")
    dialogSuffix(rows=4, columns=2)
    }

oneWayAnova <- function(){
    if (!checkActiveDataSet()) return()
    if (!checkNumeric()) return()
    if (!checkFactors()) return()
    initializeDialog(title="One-Way Analysis of Variance")
    groupBox <- variableListBox(top, .factors, title="Groups (pick one)")
    responseBox <- variableListBox(top, .numeric, title="Response Variable (pick one)")
    optionsFrame <- tkframe(top)
    pairwiseVariable <- tclVar("0")
    pairwiseCheckBox <- tkcheckbutton(optionsFrame, variable=pairwiseVariable)
    onOK <- function(){
        group <- getSelection(groupBox)
        response <- getSelection(responseBox)
        if (length(group) == 0){
            errorCondition(recall=oneWayAnova, message="You must selection a groups factor.")
            return()
            }
        if (length(response) == 0){
            errorCondition(recall=oneWayAnova, message="You must selection a response variable.")
            return()
            }
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        doItAndPrint(paste("anova(lm(", response, " ~ ", group, ", data=", .activeDataSet, "))", sep=""))
        doItAndPrint(paste("tapply(", .activeDataSet, "$", response, ", ", .activeDataSet, "$", group, 
            ", mean, na.rm=TRUE) # means", sep=""))
        doItAndPrint(paste("tapply(", .activeDataSet, "$", response, ", ", .activeDataSet, "$", group, 
            ", sd, na.rm=TRUE) # std. deviations", sep=""))
        doItAndPrint(paste("tapply(", .activeDataSet, "$", response, ", ", .activeDataSet, "$", group, 
            ", function(x) sum(!is.na(x))) # counts", sep=""))
        pairwise <- tclvalue(pairwiseVariable)
        if (pairwise == 1) {
            if (eval(parse(text=paste("length(levels(", .activeDataSet, "$", group, ")) < 3")))) 
                tkmessageBox (message="Factor has fewer than 3 levels; pairwise comparisons omitted.",
                    icon="warning", type="ok")
            else doItAndPrint(paste("summary(simtest(", response, " ~ ", group, 
                ', type="Tukey", data=', .activeDataSet, '))', sep=""))
            }
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="anova")
    tkgrid(getFrame(groupBox), getFrame(responseBox), sticky="nw")
    tkgrid(tklabel(optionsFrame, text="Pairwise comparisons of means"), pairwiseCheckBox, sticky="w")
    tkgrid(optionsFrame, sticky="w")
    tkgrid(buttonsFrame, columnspan=2, sticky="w")
    dialogSuffix(rows=4, columns=2)
    }
    
multiWayAnova <- function(){
    if (!checkActiveDataSet()) return()
    if (!checkNumeric()) return()
    if (!checkFactors()) return()
    initializeDialog(title="Multi-Way Analysis of Variance")
    groupBox <- variableListBox(top, .factors, selectmode="multiple", title="Factors (pick one or more)")
    responseBox <- variableListBox(top, .numeric, title="Response Variable (pick one)")
    onOK <- function(){
        groups <- getSelection(groupBox)
        response <- getSelection(responseBox)
        if (length(groups) == 0){
            errorCondition(recall=multiWayAnova, message="You must selection at least one factor.")
            return()
            }
        if (length(response) == 0){
            errorCondition(recall=multiWayAnova, message="You must selection a response variable.")
            return()
            }
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        groups.list <- paste(paste(groups, "=", .activeDataSet, "$", groups, sep=""), collapse=", ")
        doItAndPrint(paste("Anova(lm(", response, " ~ ", paste(groups, collapse="*"),
             ", data=", .activeDataSet, "))", sep=""))
        doItAndPrint(paste("tapply(", .activeDataSet, "$", response, ", list(", groups.list,
             "), mean, na.rm=TRUE) # means", sep=""))
        doItAndPrint(paste("tapply(", .activeDataSet, "$", response, ", list(", groups.list,
             "), sd, na.rm=TRUE) # std. deviations", sep=""))
        doItAndPrint(paste("tapply(", .activeDataSet, "$", response, ", list(", groups.list,
             "), function(x) sum(!is.na(x))) # counts", sep=""))
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="Anova")
    tkgrid(getFrame(groupBox), getFrame(responseBox), sticky="nw")
    tkgrid(buttonsFrame, columnspan=2, sticky="w")
    dialogSuffix(rows=3, columns=2)
    }
# Statistics Menu dialogs

# last modified 29 Nov 04 by J. Fox

    # Models menu
    
linearRegressionModel <- function(){
    if (!checkActiveDataSet()) return()
    if (!checkNumeric(2)) return()
    initializeDialog(title="Linear Regression")
    variablesFrame <- tkframe(top)
    xBox <- variableListBox(variablesFrame, .numeric, selectmode="multiple", 
        title="Explanatory variables (pick one or more)")
    yBox <- variableListBox(variablesFrame, .numeric, title="Response variable (pick one)")
    assign(".modelNumber", .modelNumber + 1, envir=.GlobalEnv)
    modelName <- tclVar(paste("RegModel.", .modelNumber, sep=""))
    modelFrame <- tkframe(top)
    model <- tkentry(modelFrame, width="20", textvariable=modelName)
    subsetBox()
    onOK <- function(){
        x <- getSelection(xBox)
        y <- getSelection(yBox)
        if (0 == length(y)) {
            assign(".modelNumber", .modelNumber - 1, envir=.GlobalEnv) 
            errorCondition(recall=linearRegressionModel, message="You must select a response variable.")
            return()
            }
        if (0 == length(x)) {
            assign(".modelNumber", .modelNumber - 1, envir=.GlobalEnv) 
            errorCondition(recall=linearRegressionModel, message="No explanatory variables selected.")
            return()
            }        
        if (is.element(y, x)) {
            assign(".modelNumber", .modelNumber - 1, envir=.GlobalEnv) 
            errorCondition(recall=linearRegressionModel, message="Response and explanatory variables must be different.")
            return()
            }
        subset <- tclvalue(subsetVariable)
        if (trim.blanks(subset) == "<all valid cases>" || trim.blanks(subset) == ""){
            subset <- ""
            assign(".modelWithSubset", FALSE, envir=.GlobalEnv)
            }
        else{
            subset <- paste(", subset=", subset, sep="")
            assign(".modelWithSubset", TRUE, envir=.GlobalEnv)            
            }
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        modelValue <- trim.blanks(tclvalue(modelName))
        if (!is.valid.name(modelValue)){
            assign(".modelNumber", .modelNumber - 1, envir=.GlobalEnv) 
            errorCondition(recall=linearRegressionModel, message=paste('"', modelValue, '" is not a valid name.', sep=""))
            return()
            }
        if (is.element(modelValue, listLinearModels())) {
            if ("no" == tclvalue(checkReplace(modelValue, type="Model"))){
                assign(".modelNumber", .modelNumber - 1, envir=.GlobalEnv) 
                if (.grab.focus) tkgrab.release(top)
                tkdestroy(top)
                linearRegressionModel()
                return()
                }
            }
        activeModel(modelValue)
        command <- paste("lm(", y, "~", paste(x, collapse="+"),
            ", data=", .activeDataSet, subset, ")", sep="")
        logger(paste(modelValue, " <- ", command, sep=""))
        assign(modelValue, justDoIt(command), envir=.GlobalEnv)
        doItAndPrint(paste("summary(", modelValue, ")", sep=""))
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="lm", model=TRUE)
    tkgrid(tklabel(modelFrame, text="Enter name for model:"), model, sticky="w")
    tkgrid(modelFrame, sticky="w")
    tkgrid(getFrame(yBox), tklabel(variablesFrame, text="    "), getFrame(xBox), sticky="nw")
    tkgrid(variablesFrame, sticky="w")    
    tkgrid(subsetFrame, sticky="w")
    tkgrid(buttonsFrame, stick="w")
    tkgrid.configure(helpButton, sticky="e")
    dialogSuffix(rows=4, columns=1)
    }

linearModel <- function(){
    if (!checkActiveDataSet()) return()
    if (!checkNumeric()) return()
    if (!checkVariables(2)) return()
    initializeDialog(title="Linear Model")
    currentModel <- if (!is.null(.activeModel)) 
        eval(parse(text=paste("class(", .activeModel, ")[1] == 'lm'", sep="")), 
            envir=.GlobalEnv) 
        else FALSE
    if (currentModel) {
        currentFields <- formulaFields(eval(parse(text=.activeModel), 
            envir=.GlobalEnv))
        if (currentFields$data != .activeDataSet) currentModel <- FALSE
        }
    assign(".modelNumber", .modelNumber + 1, envir=.GlobalEnv)
    modelName <- tclVar(paste("LinearModel.", .modelNumber, sep=""))
    modelFrame <- tkframe(top)
    model <- tkentry(modelFrame, width="20", textvariable=modelName)
    onOK <- function(){
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        modelValue <- trim.blanks(tclvalue(modelName))
        if (!is.valid.name(modelValue)){
            errorCondition(recall=linearModel, message=paste('"', modelValue, '" is not a valid name.', sep=""), model=TRUE)
            return()
            }
        subset <- tclvalue(subsetVariable)
        if (trim.blanks(subset) == "<all valid cases>" || trim.blanks(subset) == ""){
            subset <- ""
            assign(".modelWithSubset", FALSE, envir=.GlobalEnv)
            }
        else{
            subset <- paste(", subset=", subset, sep="")
            assign(".modelWithSubset", TRUE, envir=.GlobalEnv)            
            }
        check.empty <- gsub(" ", "", tclvalue(lhsVariable))
        if ("" == check.empty) {
            errorCondition(recall=linearModel, message="Left-hand side of model empty.", model=TRUE) 
            return()
            }
        check.empty <- gsub(" ", "", tclvalue(rhsVariable))
        if ("" == check.empty) {
            errorCondition(recall=linearModel, message="Right-hand side of model empty.", model=TRUE)
            return()
            }
        if (is.element(modelValue, listLinearModels())) {
            if ("no" == tclvalue(checkReplace(modelValue, type="Model"))){
                assign(".modelNumber", .modelNumber - 1, envir=.GlobalEnv) 
                if (.grab.focus) tkgrab.release(top)
                tkdestroy(top)
                linearModel()
                return()
                }
            }
        activeModel(modelValue)
        formula <- paste(tclvalue(lhsVariable), tclvalue(rhsVariable), sep=" ~ ")
        command <- paste("lm(", formula,
            ", data=", .activeDataSet, subset, ")", sep="")
        logger(paste(modelValue, " <- ", command, sep=""))
        assign(modelValue, justDoIt(command), envir=.GlobalEnv)
        doItAndPrint(paste("summary(", modelValue, ")", sep=""))
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="linearModel", model=TRUE)
    tkgrid(tklabel(modelFrame, text="Enter name for model:"), model, sticky="w")
    tkgrid(modelFrame, sticky="w")
    modelFormula()
    subsetBox(model=TRUE)
    tkgrid(getFrame(xBox), sticky="w")
    tkgrid(outerOperatorsFrame, sticky="w")
    tkgrid(formulaFrame, sticky="w")
    tkgrid(subsetFrame, sticky="w")
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix(rows=6, columns=1, focus=lhsEntry)
    }

generalizedLinearModel <- function(){
    families <- c("gaussian", "binomial", "poisson", "Gamma", "inverse.gaussian", 
        "quasibinomial", "quasipoisson")
    links <- c("identity", "inverse", "log", "logit", "probit", 
        "cloglog", "sqrt", "1/mu^2")  
    availableLinks <- matrix(c(
        TRUE,  TRUE,  TRUE,  FALSE, FALSE, FALSE, FALSE, FALSE,
        FALSE, FALSE, FALSE, TRUE,  TRUE,  TRUE,  FALSE, FALSE,
        TRUE,  FALSE, TRUE,  FALSE, FALSE, FALSE, TRUE,  FALSE,
        TRUE,  TRUE,  TRUE,  FALSE, FALSE, FALSE, FALSE, FALSE,
        TRUE,  TRUE,  TRUE,  FALSE, FALSE, FALSE, FALSE, TRUE,
        FALSE, FALSE, FALSE, TRUE,  TRUE,  TRUE,  FALSE, FALSE,
        TRUE,  FALSE, TRUE,  FALSE, FALSE, FALSE, TRUE,  FALSE),
        7, 8, byrow=TRUE)
    rownames(availableLinks) <- families
    colnames(availableLinks) <- links
    canonicalLinks <- c("identity", "logit", "log", "inverse", "1/mu^2", "logit", "log")
    names(canonicalLinks) <- families
    if (!checkActiveDataSet()) return()
    if (!checkVariables(2)) return()
    initializeDialog(title="Generalized Linear Model")
    currentModel <- if (!is.null(.activeModel)) 
        eval(parse(text=paste("class(", .activeModel, ")[1] == 'glm'", sep="")), 
            envir=.GlobalEnv)
        else FALSE
    if (currentModel) {
        currentFields <- formulaFields(eval(parse(text=.activeModel), 
            envir=.GlobalEnv), glm=TRUE)
        if (currentFields$data != .activeDataSet) currentModel <- FALSE
        }
    modelFormula()
    assign(".modelNumber", .modelNumber + 1, envir=.GlobalEnv)
    modelName <- tclVar(paste("GLM.", .modelNumber, sep=""))
    modelFrame <- tkframe(top)
    model <- tkentry(modelFrame, width="20", textvariable=modelName)
    linkFamilyFrame <- tkframe(top)
    familyFrame <- tkframe(linkFamilyFrame)
    familyBox <- tklistbox(familyFrame, height="4", exportselection="FALSE",
        selectmode="single", background="white")
    familyScroll <- tkscrollbar(familyFrame, repeatinterval=5, 
        command=function(...) tkyview(familyBox, ...))
    tkconfigure(familyBox, yscrollcommand=function(...) tkset(familyScroll, ...))
    for (fam in families) tkinsert(familyBox, "end", fam)
    linkFrame <- tkframe(linkFamilyFrame)
    linkBox <- tklistbox(linkFrame, height="4", exportselection="FALSE",
        selectmode="single", background="white")
    subsetBox(model=TRUE)
    onFamilySelect <- function(){
        family <- families[as.numeric(tkcurselection(familyBox)) + 1]
        availLinks <- links[availableLinks[family,]]
        tkdelete(linkBox, "0", "end")
        for (lnk in availLinks) tkinsert(linkBox, "end", lnk)
        canLink <- canonicalLinks[family]
        tkconfigure(linkBox, height=length(availLinks))
        tkselection.set(linkBox, which(canLink == availLinks) - 1)
        }
    onOK <- function(){
        check.empty <- gsub(" ", "", tclvalue(lhsVariable))
        if ("" == check.empty) {
            errorCondition(recall=generalizedLinearModel, model=TRUE, message="Left-hand side of model empty.")
            return()
            }
        check.empty <- gsub(" ", "", tclvalue(rhsVariable))
        if ("" == check.empty) {
            errorCondition(recall=generalizedLinearModel, model=TRUE, message="Right-hand side of model empty.")
            return()
            }
        modelValue <- trim.blanks(tclvalue(modelName))
        if (!is.valid.name(modelValue)){
            errorCondition(recall=generalizedLinearModel, model=TRUE, message=paste('"', modelValue, '" is not a valid name.', sep=""))
            return()
            }
        if (is.element(modelValue, listGeneralizedLinearModels())) {
            if ("no" == tclvalue(checkReplace(modelValue))){
                if (.grab.focus) tkgrab.release(top)
                tkdestroy(top)
                generalizedLinearModel()
                return()
                }
            }
        activeModel(modelValue)
        formula <- paste(tclvalue(lhsVariable), tclvalue(rhsVariable), sep=" ~ ")
        family <- families[as.numeric(tkcurselection(familyBox)) + 1]
        availLinks <- links[availableLinks[family,]]
        link <- availLinks[as.numeric(tkcurselection(linkBox)) + 1]
        subset <- tclvalue(subsetVariable)
        if (trim.blanks(subset) == "<all valid cases>" || trim.blanks(subset) == ""){
            subset <- ""
            assign(".modelWithSubset", FALSE, envir=.GlobalEnv)
            }
        else{
            subset <- paste(", subset=", subset, sep="")
            assign(".modelWithSubset", TRUE, envir=.GlobalEnv)            
            }
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        command <- paste("glm(", formula, ", family=", family, "(", link,
            "), data=", .activeDataSet, subset, ")", sep="")
        logger(paste(modelValue, " <- ", command, sep=""))
        assign(modelValue, justDoIt(command), envir=.GlobalEnv)
        doItAndPrint(paste("summary(", modelValue, ")", sep=""))
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="generalizedLinearModel")
    helpButton <- tkbutton(buttonsFrame, text="Help", width="12", command=onHelp)
    tkgrid(tklabel(modelFrame, text="Enter name for model:"), model, sticky="w")
    tkgrid(modelFrame, sticky="w")    
    tkgrid(getFrame(xBox), sticky="w")
    tkgrid(outerOperatorsFrame, sticky="w")
    tkgrid(formulaFrame, sticky="w")
    tkgrid(subsetFrame, sticky="w")
        tkgrid(tklabel(linkFamilyFrame, text="Family (double-click to select)", fg="blue"), 
        tklabel(linkFamilyFrame, text="   "), tklabel(linkFamilyFrame, text="Link function", fg="blue"), sticky="w")
    tkgrid(familyBox, familyScroll, sticky="nw")
    tkgrid(linkBox, sticky="nw")
    tkgrid(familyFrame, tklabel(linkFamilyFrame, text="   "), linkFrame, sticky="nw")
    tkgrid(linkFamilyFrame, sticky="w")    
    tkgrid(buttonsFrame, sticky="w")
    tkgrid.configure(familyScroll, sticky="ns")   
    fam <- if (currentModel) which(currentFields$family == families) - 1
        else 1
    tkselection.set(familyBox, fam)
    availLinks <- links[availableLinks[fam + 1,]]
    for (lnk in availLinks) tkinsert(linkBox, "end", lnk)
    tkconfigure(linkBox, height=length(availLinks))
    lnk <- if (currentModel) which(currentFields$link == availLinks) - 1
            else 0
    tkselection.set(linkBox, lnk)
    tkbind(familyBox, "<Double-ButtonPress-1>", onFamilySelect)
    dialogSuffix(rows=7, columns=1, focus=lhsEntry)
    }

proportionalOddsModel <- function(){
    if (!checkActiveDataSet()) return()
    if (!checkVariables(2)) return()
    initializeDialog(title="Proportional-Odds Logit Model")
    currentModel <- if (!is.null(.activeModel)) 
        eval(parse(text=paste("class(", .activeModel, ")[1] == 'polr'", sep="")), 
            envir=.GlobalEnv) 
        else FALSE
    if (currentModel) {
        currentFields <- formulaFields(eval(parse(text=.activeModel), 
            envir=.GlobalEnv))
        if (currentFields$data != .activeDataSet) currentModel <- FALSE
        }
    assign(".modelNumber", .modelNumber + 1, envir=.GlobalEnv)
    modelName <- tclVar(paste("POM.", .modelNumber, sep=""))
    modelFrame <- tkframe(top)
    model <- tkentry(modelFrame, width="20", textvariable=modelName)
    onOK <- function(){
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        modelValue <- trim.blanks(tclvalue(modelName))
        if (!is.valid.name(modelValue)){
            errorCondition(recall=proportionalOddsModel, message=paste('"', modelValue, '" is not a valid name.', sep=""), model=TRUE)
            return()
            }
        subset <- tclvalue(subsetVariable)
        if (trim.blanks(subset) == "<all valid cases>" || trim.blanks(subset) == ""){
            subset <- ""
            assign(".modelWithSubset", FALSE, envir=.GlobalEnv)
            }
        else{
            subset <- paste(", subset=", subset, sep="")
            assign(".modelWithSubset", TRUE, envir=.GlobalEnv)            
            }
        check.empty <- gsub(" ", "", tclvalue(lhsVariable))
        if ("" == check.empty) {
            errorCondition(recall=proportionalOddsModel, message="Left-hand side of model empty.", model=TRUE) 
            return()
            }
        check.empty <- gsub(" ", "", tclvalue(rhsVariable))
        if ("" == check.empty) {
            errorCondition(recall=proportionalOddsModel, message="Right-hand side of model empty.", model=TRUE)
            return()
            }
        if (!is.factor(eval(parse(text=tclvalue(lhsVariable)), envir=eval(parse(text=.activeDataSet), envir=.GlobalEnv)))){
            errorCondition(recall=proportionalOddsModel, message="Response variable must be a factor")
            return()
            }
        if (is.element(modelValue, listProportionalOddsModels())) {
            if ("no" == tclvalue(checkReplace(modelValue, type="Model"))){
                assign(".modelNumber", .modelNumber - 1, envir=.GlobalEnv) 
                if (.grab.focus) tkgrab.release(top)
                tkdestroy(top)
                linearModel()
                return()
                }
            }
        activeModel(modelValue)
        formula <- paste(tclvalue(lhsVariable), tclvalue(rhsVariable), sep=" ~ ")
        command <- paste("polr(", formula,
            ", data=", .activeDataSet, subset, ", Hess=TRUE)", sep="")
        logger(paste(modelValue, " <- ", command, sep=""))
        assign(modelValue, justDoIt(command), envir=.GlobalEnv)
        doItAndPrint(paste("summary(", modelValue, ")", sep=""))
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="polr", model=TRUE)
    tkgrid(tklabel(modelFrame, text="Enter name for model:"), model, sticky="w")
    tkgrid(modelFrame, sticky="w")
    modelFormula()
    subsetBox(model=TRUE)
    tkgrid(getFrame(xBox), sticky="w")
    tkgrid(outerOperatorsFrame, sticky="w")
    tkgrid(formulaFrame, sticky="w")
    tkgrid(subsetFrame, sticky="w")
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix(rows=6, columns=1, focus=lhsEntry)
    }
    
multinomialLogitModel <- function(){
    if (!checkActiveDataSet()) return()
    if (!checkVariables(2)) return()
    initializeDialog(title="Multinomial Logit Model")
    currentModel <- if (!is.null(.activeModel)) 
        eval(parse(text=paste("class(", .activeModel, ")[1] == 'multinom'", sep="")), 
            envir=.GlobalEnv) 
        else FALSE
    if (currentModel) {
        currentFields <- formulaFields(eval(parse(text=.activeModel), 
            envir=.GlobalEnv))
        if (currentFields$data != .activeDataSet) currentModel <- FALSE
        }
    assign(".modelNumber", .modelNumber + 1, envir=.GlobalEnv)
    modelName <- tclVar(paste("MLM.", .modelNumber, sep=""))
    modelFrame <- tkframe(top)
    model <- tkentry(modelFrame, width="20", textvariable=modelName)
    onOK <- function(){
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        modelValue <- trim.blanks(tclvalue(modelName))
        if (!is.valid.name(modelValue)){
            errorCondition(recall=multinomialLogitModel, message=paste('"', modelValue, '" is not a valid name.', sep=""), model=TRUE)
            return()
            }
        subset <- tclvalue(subsetVariable)
        if (trim.blanks(subset) == "<all valid cases>" || trim.blanks(subset) == ""){
            subset <- ""
            assign(".modelWithSubset", FALSE, envir=.GlobalEnv)
            }
        else{
            subset <- paste(", subset=", subset, sep="")
            assign(".modelWithSubset", TRUE, envir=.GlobalEnv)            
            }
        check.empty <- gsub(" ", "", tclvalue(lhsVariable))
        if ("" == check.empty) {
            errorCondition(recall=multinomialLogitModel, message="Left-hand side of model empty.", model=TRUE) 
            return()
            }
        check.empty <- gsub(" ", "", tclvalue(rhsVariable))
        if ("" == check.empty) {
            errorCondition(recall=multinomialLogitModel, message="Right-hand side of model empty.", model=TRUE)
            return()
            }
        if (!is.factor(eval(parse(text=tclvalue(lhsVariable)), envir=eval(parse(text=.activeDataSet), envir=.GlobalEnv)))){
            errorCondition(recall=multinomialLogitModel, message="Response variable must be a factor")
            return()
            }
        if (is.element(modelValue, listMultinomialLogitModels())) {
            if ("no" == tclvalue(checkReplace(modelValue, type="Model"))){
                assign(".modelNumber", .modelNumber - 1, envir=.GlobalEnv) 
                if (.grab.focus) tkgrab.release(top)
                tkdestroy(top)
                linearModel()
                return()
                }
            }
        activeModel(modelValue)
        formula <- paste(tclvalue(lhsVariable), tclvalue(rhsVariable), sep=" ~ ")
        command <- paste("multinom(", formula,
            ", data=", .activeDataSet, subset, ", trace=FALSE)", sep="")
        logger(paste(modelValue, " <- ", command, sep=""))
        assign(modelValue, justDoIt(command), envir=.GlobalEnv)
        doItAndPrint(paste("summary(", modelValue, ", cor=FALSE)", sep=""))
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="multinom", model=TRUE)
    tkgrid(tklabel(modelFrame, text="Enter name for model:"), model, sticky="w")
    tkgrid(modelFrame, sticky="w")
    modelFormula()
    subsetBox(model=TRUE)
    tkgrid(getFrame(xBox), sticky="w")
    tkgrid(outerOperatorsFrame, sticky="w")
    tkgrid(formulaFrame, sticky="w")
    tkgrid(subsetFrame, sticky="w")
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix(rows=6, columns=1, focus=lhsEntry)
    }

formulaFields <- function(model, glm=FALSE){
    formula <- as.character(model$call$formula)
    lhs <- formula[2]
    rhs <- formula[3]
    data <- as.character(model$call$data)
    which.subset <- which("subset" == names(model$call))
    subset <- if (0 == length(which.subset)) ""
        else as.character(model$call)[[which.subset]]
    if (glm) {
        fam <- as.character(model$call$family)
        family <- fam[1]
        link <- fam[2]
        }
    else {
        family <- NULL
        link <- NULL
        }
    list(lhs=lhs, rhs=rhs, data=data, subset=subset, family=family, link=link)
    }
# Statistics Menu dialogs

# last modified 10 July 04 by J. Fox

    # Nonparametric tests menu
    
twoSampleWilcoxonTest <- function(){
    if (!checkActiveDataSet()) return()
    if (!checkNumeric()) return()
    if (!checkTwoLevelFactors()) return()
    initializeDialog(title="Two-Sample Wilcoxon Test")
    groupBox <- variableListBox(top, .twoLevelFactors, title="Groups (pick one)")
    responseBox <- variableListBox(top, .numeric, title="Response Variable (pick one)")
    onOK <- function(){
        group <- getSelection(groupBox)
        if (length(group) == 0) {
            errorCondition(recall=twoSampleWilcoxonTest, message="You must select a groups variable.")
            return()
            }
        response <- getSelection(responseBox)
        if (length(response) == 0) {
            errorCondition(recall=twoSampleWilcoxonTest, message="You must select a response variable.")
            return()
            }
        alternative <- as.character(tclvalue(alternativeVariable))
        test <- as.character(tclvalue(testVariable))
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        doItAndPrint(paste("tapply(", paste(.activeDataSet,"$", response, sep=""),
            ", ", paste(.activeDataSet,"$", group, sep=""), ", median, na.rm=TRUE)", sep=""))
        if (test == "default"){
            doItAndPrint(paste("wilcox.test(", response, " ~ ", group, ', alternative="', 
            alternative, '", data=', .activeDataSet, ")", sep=""))
            }
        else doItAndPrint(paste("wilcox.test(", response, " ~ ", group, ", alternative='", 
            alternative, "', exact=", test=="exact", 
            ", correct=", test=="correct",", data=", .activeDataSet, ")", sep=""))
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="wilcox.test")
    radioButtons(name="alternative", buttons=c("twosided", "less", "greater"), values=c("two.sided", "less", "greater"),
        labels=c("Two-sided", "Difference < 0", "Difference > 0"), title="Alternative Hypothesis")
    radioButtons(name="test", buttons=c("default", "exact", "normal", "correct"), 
        labels=c("Default", "Exact", "Normal approximation", "Normal approximation with\ncontinuity correction"), 
        title="Type of Test")
    tkgrid(getFrame(groupBox), getFrame(responseBox), sticky="nw")
    groupsLabel(groupsBox=groupBox, columnspan=2)
    tkgrid(alternativeFrame, testFrame, sticky="nw")
    tkgrid(buttonsFrame, columnspan=2, sticky="w")
    dialogSuffix(rows=4, columns=2)
    }    

pairedWilcoxonTest <- function(){
    if (!checkActiveDataSet()) return()
    if (!checkNumeric(2)) return()
    initializeDialog(title="Paired Wilcoxon Test")
    xBox <- variableListBox(top, .numeric, title="First variable (pick one)")
    yBox <- variableListBox(top, .numeric, title="Second variable (pick one)")
    onOK <- function(){
        x <- getSelection(xBox)
        y <- getSelection(yBox)
        alternative <- as.character(tclvalue(alternativeVariable))
        test <- as.character(tclvalue(testVariable))
        if (length(x) == 0 | length(y) == 0) {
            errorCondition(recall=pairedWilcoxonTest, message="You must select two variables.")
            return()
            }
        if (x == y) {
            errorCondition(recall=pairedWilcoxonTest, message="The two variables must be different.")
            return()
            }
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        doItAndPrint(paste("median(", .activeDataSet, "$", x, " - ", .activeDataSet, "$", y, 
            ", na.rm=TRUE) # median difference", sep=""))
        if (test == "default"){
             doItAndPrint(paste("wilcox.test(", .activeDataSet, "$", x, ", ", 
                .activeDataSet, "$", y,
                ", alternative='", alternative,
                "', paired=TRUE)", sep=""))           
            }
        else if (test == "exact"){
            doItAndPrint(paste("wilcox.test(", .activeDataSet, "$", x, ", ", 
                .activeDataSet, "$", y,
                ", alternative='", alternative,
                "', exact=TRUE, paired=TRUE)", sep=""))
                }
        else {
            doItAndPrint(paste("wilcox.test(", .activeDataSet, "$", x, ", ", 
                .activeDataSet, "$", y,
                ", alternative='", alternative, "', correct=", test=="correct",
                ", exact=FALSE, paired=TRUE)", sep=""))
                }
        tkdestroy(top)
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="wilcox.test")
    radioButtons(name="alternative", buttons=c("twosided", "less", "greater"), values=c("two.sided", "less", "greater"),
        labels=c("Two-sided", "Difference < 0", "Difference > 0"), title="Alternative Hypothesis")
    radioButtons(name="test", buttons=c("default", "exact", "normal", "correct"), 
        labels=c("Default", "Exact", "Normal approximation", "Normal approximation with\ncontinuity correction"), 
        title="Type of Test")
    tkgrid(getFrame(xBox), getFrame(yBox), sticky="nw")    
    tkgrid(alternativeFrame, testFrame, sticky="nw")
    tkgrid(buttonsFrame, columnspan=2, sticky="w")
    dialogSuffix(rows=3, columns=2)
    }
    
KruskalWallisTest <- function(){
    if (!checkActiveDataSet()) return()
    if (!checkNumeric()) return()
    if (!checkFactors()) return()
    initializeDialog(title="Kruskal-Wallis Rank Sum Test")
    groupBox <- variableListBox(top, .factors, title="Groups (pick one)")
    responseBox <- variableListBox(top, .numeric, title="Response Variable (pick one)")
    onOK <- function(){
        group <- getSelection(groupBox)
        if (length(group) == 0) {
            errorCondition(recall=KruskalWallisTest, message="You must select a groups variable.")
            return()
            }
        response <- getSelection(responseBox)
        if (length(response) == 0) {
            errorCondition(recall=KruskalWallisTest, message="You must select a response variable.")
            return()
            }
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        doItAndPrint(paste("tapply(", paste(.activeDataSet, "$", response, sep=""),
            ", ", paste(.activeDataSet, "$", group, sep=""), ", median, na.rm=TRUE)", sep=""))
        doItAndPrint(paste("kruskal.test(", response, " ~ ", group, ", data=",
            .activeDataSet, ")", sep=""))
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="kruskal.test")
    tkgrid(getFrame(groupBox), getFrame(responseBox), sticky="nw")
    tkgrid(buttonsFrame, columnspan=2, sticky="w")
    dialogSuffix(rows=2, columns=2)
    }
# Statistics Menu dialogs

# last modified 10 July 04 by J. Fox

    # Proportions menu
    
singleProportionTest <- function(){
    if (!checkActiveDataSet()) return()
    if (!checkTwoLevelFactors()) return()
    initializeDialog(title="Single-Sample Proportion Test")
    xBox <- variableListBox(top, .twoLevelFactors, title="Variable (pick one)")
    onOK <- function(){
        x <- getSelection(xBox)
        if (length(x) == 0) {
            errorCondition(recall=singleProportionTest, message="You must select a variable.")
            return()
            }
        alternative <- as.character(tclvalue(alternativeVariable))
        level <- tclvalue(confidenceLevel)
        test <- as.character(tclvalue(testVariable))
        p <- tclvalue(pVariable)
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        command <- paste("xtabs(~", x, ", data=", .activeDataSet, ")")
        logger(paste(".Table <-", command))
        assign(".Table", justDoIt(command), envir=.GlobalEnv)
        doItAndPrint(".Table")
        if (test == "normal") doItAndPrint(paste("prop.test(rbind(.Table), alternative='", 
            alternative, "', p=", p, ", conf.level=", level, ", correct=FALSE)", sep=""))
        else if (test == "corrected") doItAndPrint(paste("prop.test(rbind(.Table), alternative='", 
            alternative, "', p=", p, ", conf.level=", level, ", correct=TRUE)", sep=""))
        else doItAndPrint(paste("binom.test(rbind(.Table), alternative='", 
            alternative, "', p=", p, ", conf.level=", level, ")", sep=""))
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="prop.test")
    radioButtons(top, name="alternative", buttons=c("twosided", "less", "greater"), values=c("two.sided", "less", "greater"),
        labels=c("Population proportion = p0", "Population proportion < p0", "Population proportion > p0"), title="Alternative Hypothesis")
    rightFrame <- tkframe(top)
    confidenceFrame <- tkframe(rightFrame)
    confidenceLevel <- tclVar(".95")
    confidenceField <- tkentry(confidenceFrame, width="6", textvariable=confidenceLevel)
    pFrame <- tkframe(rightFrame)
    pVariable <- tclVar(".5")
    pField <- tkentry(pFrame, width="6", textvariable=pVariable)
    radioButtons(name="test", buttons=c("normal", "corrected", "exact"), 
        labels=c("Normal approximation", "Normal approximation with\ncontinuity correction", "Exact binomial"), 
        title="Type of Test")
    tkgrid(getFrame(xBox), sticky="nw")    
    tkgrid(tklabel(pFrame, text="Null hypothesis: p = ", fg="blue"), pField, sticky="w")
    tkgrid(pFrame, sticky="w")
    tkgrid(tklabel(rightFrame, text=""))
    tkgrid(tklabel(confidenceFrame, text="Confidence Level: ", fg="blue"), confidenceField, sticky="w")
    tkgrid(confidenceFrame, sticky="w")
    tkgrid(alternativeFrame, rightFrame, sticky="nw")
    tkgrid(testFrame, sticky="w")
    tkgrid(buttonsFrame, columnspan=2, sticky="w")
    tkgrid.configure(confidenceField, sticky="e")
    dialogSuffix(rows=4, columns=2)
    }

twoSampleProportionsTest <- function(){
    if (!checkActiveDataSet()) return()
    if (!checkTwoLevelFactors(2)) return()
    initializeDialog(title="Two-Sample Proportions Test")
    groupsBox <- variableListBox(top, .twoLevelFactors, title="Groups (pick one)")
    xBox <- variableListBox(top, .twoLevelFactors, title="Response Variable (pick one)")
    onOK <- function(){
        groups <- getSelection(groupsBox)
        if (length(groups) == 0) {
            errorCondition(recall=twoSampleProportionsTest, message="You must select a groups variable.")
            return()
            }
        x <- getSelection(xBox)
        if (length(x) == 0) {
            errorCondition(recall=twoSampleProportionsTest, message="You must select a response variable.")
            return()
            }
        if (x == groups) {
            errorCondition(recall=twoSampleProportionsTest, message="Groups and response variables must be different.")
            return()
            }
        alternative <- as.character(tclvalue(alternativeVariable))
        level <- tclvalue(confidenceLevel)
        test <- as.character(tclvalue(testVariable))
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        command <- paste("xtabs(~", groups, "+", x, ", data=", .activeDataSet, ")", sep="")
        logger(paste(".Table <-", command))
        assign(".Table", justDoIt(command), envir=.GlobalEnv)
        doItAndPrint("rowPercents(.Table)")
        if (test == "normal") doItAndPrint(paste("prop.test(.Table, alternative='", 
            alternative, "', conf.level=", level, ", correct=FALSE)", sep=""))
        else doItAndPrint(paste("prop.test(.Table, alternative='", 
            alternative, "', conf.level=", level, ", correct=TRUE)", sep=""))
        logger("remove(.Table)")
        remove(.Table, envir=.GlobalEnv)
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="prop.test")
    radioButtons(name="alternative", buttons=c("twosided", "less", "greater"), values=c("two.sided", "less", "greater"),
        labels=c("Two-sided", "Difference < 0", "Difference > 0"), title="Alternative Hypothesis")
    rightFrame <- tkframe(top)
    confidenceFrame <- tkframe(rightFrame)
    confidenceLevel <- tclVar(".95")
    confidenceField <- tkentry(confidenceFrame, width="6", textvariable=confidenceLevel)
    radioButtons(name="test", buttons=c("normal", "corrected"), 
        labels=c("Normal approximation", "Normal approximation with\ncontinuity correction"), title="Type of Test")
    tkgrid(getFrame(groupsBox), getFrame(xBox), sticky="nw")    
    groupsLabel(columnspan=2)
    tkgrid(tklabel(confidenceFrame, text="Confidence Level: ", fg="blue"), confidenceField, sticky="w")
    tkgrid(confidenceFrame, sticky="w")
    tkgrid(alternativeFrame, rightFrame, sticky="nw")
    tkgrid(testFrame, sticky="w")
    tkgrid(buttonsFrame, columnspan=2, sticky="w")
    tkgrid.configure(confidenceField, sticky="e")
    dialogSuffix(rows=5, columns=2)
    }
# Statistics Menu dialogs

# last modified 13 July 04 by J. Fox

    # Summaries menu
    
summarizeDataSet <- function(){
    if (!checkActiveDataSet()) return()
    nvar <- length(.variables)
    if (nvar > 10){
        response <- tkmessageBox(message=paste("There are ", nvar, " variables in the data set ",
            .activeDataSet, ".\nDo you want to proceed?", sep=""),
            icon="question", type="okcancel", default="cancel")
        if ("cancel" == tclvalue(response)) {
            tkfocus(.commander)        
            return()
            }
        }
    doItAndPrint(paste("summary(", .activeDataSet, ")", sep=""))
    }

numericalSummaries <- function(){
    if (!checkActiveDataSet()) return()
    if (!checkNumeric()) return()
    initializeDialog(title="Numerical Summaries")
    xBox <- variableListBox(top, .numeric, title="Variable (pick one)")
    checkBoxes(frame="checkBoxFrame", boxes=c("mean", "sd"), initialValues=c("1", "1"), labels=c("Mean", "Standard Deviation"))
    quantilesVariable <- tclVar("1")
    quantilesFrame <- tkframe(top)
    quantilesCheckBox <- tkcheckbutton(quantilesFrame, variable=quantilesVariable)
    quantiles <- tclVar("0,.25,.5,.75,1")
    quantilesEntry <- tkentry(quantilesFrame, width="20", textvariable=quantiles)
    groupsBox(recall=numericalSummaries, label="Summarize by:", initialLabel="Summarize by groups")
    onOK <- function(){
        x <- getSelection(xBox)
        if (length(x) == 0){
            errorCondition(recall=numericalSummaries, message="You must select a variable.")
            return()
            }
        quants <- paste("c(", gsub(" ", ",", tclvalue(quantiles)), ")")
        var <- paste(.activeDataSet, "$", x, sep="")
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        if (.groups == FALSE) {
            if (tclvalue(meanVariable) == "1") doItAndPrint(paste("mean(", var, ", na.rm=TRUE)", sep=""))
            if (tclvalue(sdVariable) == "1") doItAndPrint(paste("sd(", var, ", na.rm=TRUE)", sep=""))
            if (tclvalue(quantilesVariable) == "1") doItAndPrint(paste("quantile(", var, ", ",
                quants, ", na.rm=TRUE)", sep=""))
            }
        else {
            grps <- paste(.activeDataSet, "$", .groups, sep="")
            if (tclvalue(meanVariable) == "1") doItAndPrint(paste("by(", var, ",", grps,
                ", mean, na.rm=TRUE)", sep=""))
            if (tclvalue(sdVariable) == "1") doItAndPrint(paste("by(", var, ",", grps,
                ", sd, na.rm=TRUE)", sep=""))
            if (tclvalue(quantilesVariable) == "1") doItAndPrint(paste("by(", var, ",", grps,
                ", quantile, na.rm=TRUE, probs=", quants,")", sep=""))
            }
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="quantile")
    tkgrid(getFrame(xBox), sticky="nw")    
    tkgrid(checkBoxFrame, sticky="w")
    tkgrid(tklabel(quantilesFrame, text="Quantiles"), quantilesCheckBox,
        tklabel(quantilesFrame, text=" quantiles:"), quantilesEntry, sticky="w")
    tkgrid(quantilesFrame, sticky="w")
    tkgrid(groupsFrame, sticky="w")
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix(rows=6, columns=1)
    }

frequencyDistribution <- function(){
    if (!checkActiveDataSet()) return()
    if (!checkFactors()) return()
    initializeDialog(title="Frequency Distribution")
    xBox <- variableListBox(top, .factors, title="Variable (pick one)")
    optionsFrame <- tkframe(top)
    goodnessOfFitVariable <- tclVar("0")
    goodnessOfFitCheckBox <- tkcheckbutton(optionsFrame, variable=goodnessOfFitVariable)
    onOK <- function(){
        x <- getSelection(xBox)
        if (length(x) == 0){
            errorCondition(recall=frequencyDistribution, message="You must select a variable.")
            return()
            }
        goodnessOfFit <- tclvalue(goodnessOfFitVariable)
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        command <- paste("table(", .activeDataSet, "$", x, ")", sep="")
        logger(paste(".Table <-", command))
        assign(".Table", justDoIt(command), envir=.GlobalEnv)
        doItAndPrint(".Table  # counts")
        doItAndPrint("100*.Table/sum(.Table)  # percentages")        
        env <- environment()
        if (goodnessOfFit == 1){
            initializeDialog(subwin, title="Goodness-of-Fit Test")
            hypothesisFrame <- tkframe(subwin)
            levs <- eval(parse(text=paste("levels(", .activeDataSet, "$", x, ")", sep="")))
            n.levs <- length(levs)
            assign(".entry.1", tclVar(paste("1/", n.levs, sep="")), envir=env)
            make.entries <- "tklabel(hypothesisFrame, text='Hypothesized probabilities:   ')"
            make.lev.names <- "tklabel(hypothesisFrame, text='Factor levels:')"
            for (i in 1:n.levs) {
                entry.varname <- paste(".entry.", i, sep="")
                assign(entry.varname, tclVar(paste("1/", n.levs, sep="")), envir=env)
                make.entries <- paste(make.entries, ", ", "tkentry(hypothesisFrame, width='5', textvariable=", 
                        entry.varname, ")", sep="")
                make.lev.names <- paste(make.lev.names, ", tklabel(hypothesisFrame, text='", levs[i], "')", sep="")
                }
            eval(parse(text=paste("tkgrid(", make.lev.names, ", sticky='w')", sep="")), envir=env)
            eval(parse(text=paste("tkgrid(", make.entries, ", stick='w')", sep="")), envir=env)
            tkgrid(hypothesisFrame, sticky="w")
            onOKsub <- function(){
                probs <- rep(NA, n.levs)
                for (i in 1:n.levs){
                    entry.varname <- paste(".entry.", i, sep="")
                    entry <- eval(parse(text=eval(parse(text=paste("tclvalue(", entry.varname,")", sep="")), envir=env)))
                    if (length(entry) == 0){
                        errorCondition(subwin, message="Missing entry.")
                        return()
                        }
                    probs[i] <- entry
                    }
                probs <- na.omit(probs)
                if (length(probs) != n.levs){
                    errorCondition(subwin, message=paste("Number of valid entries (", length(probs), ")\n",
                        "not equal to number levels (", n.levs,").", sep=""))
                    return()
                    }
                if (any(probs < 0)){
                    errorCondition(subwin, message="Negative probabilities not allowed.")
                    return()
                    }
                if (abs(sum(probs) - 1) > 0.001){
                    tkmessageBox(message="Probabilities rescaled to sum to 1.", icon="warning", type="ok")
                    probs <- probs/sum(probs)
                    }
                if (.grab.focus) tkgrab.release(subwin)
                tkdestroy(subwin)
                command <- paste("c(", paste(probs, collapse=","), ")", sep="")
                logger(paste(".Probs <-", command))
                assign(".Probs", justDoIt(command), envir=.GlobalEnv)
                doItAndPrint("chisq.test(.Table, p=.Probs)")
                logger("remove(.Probs)")
                remove(.Probs, envir=.GlobalEnv)
                }
            subOKCancelHelp(subwin)
            tkgrid(subButtonsFrame, sticky="w")
            dialogSuffix(subwin, rows=2, columns=1, onOK=onOKsub, focus=subwin)
            }            
        logger("remove(.Table)") 
        remove(.Table, envir=.GlobalEnv)  
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="table")
    tkgrid(getFrame(xBox), sticky="nw")    
    tkgrid(tklabel(optionsFrame, text="Chi-square goodness-of-fit test"), goodnessOfFitCheckBox, sticky="w")
    tkgrid(optionsFrame, sticky="w")
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix(rows=3, columns=2)
    }

statisticsTable <- function(){
    if (!checkActiveDataSet()) return()
    if (!checkNumeric()) return()
    if (!checkFactors()) return()
    if (activeDataSet() == FALSE) {
        tkfocus(.commander)
        return()
        }
    if (length(.numeric) == 0){
        tkmessageBox(message="There no numeric variables in the active data set.", 
                icon="error", type="ok")
        tkfocus(.commander)
        return()
        }
    if (length(.factors) == 0){
        tkmessageBox(message="There no factors in the active data set.", 
                icon="error", type="ok")
        tkfocus(.commander)
        return()
        }
    initializeDialog(title="Table of Statistics")
    variablesFrame <- tkframe(top)
    groupBox <- variableListBox(variablesFrame, .factors, selectmode="multiple", title="Factors (pick one or more)")
    responseBox <- variableListBox(variablesFrame, .numeric, title="Response Variable (pick one)")
    radioButtons(name="statistic", buttons=c("mean", "median", "sd"), labels=c("Mean", "Median", "Standard deviation"), title="Statistic")
    otherVariable <- tclVar("")
    otherButton <- tkradiobutton(statisticFrame, variable=statisticVariable, value="other")
    otherEntry <- tkentry(statisticFrame, width="20", textvariable=otherVariable)   
    tkgrid(tklabel(statisticFrame, text="Other (specify)"), otherButton, otherEntry, sticky="w")
    onOK <- function(){
        groups <- getSelection(groupBox)
        if (0 == length(groups)) {
            errorCondition(recall=statisticsTable, message="No factors selected.")
            return()
            }
        response <- getSelection(responseBox)
        if (0 == length(response)) {
            errorCondition(recall=statisticsTable, message="You must select a response variable.")
            return()
            }
        statistic <- tclvalue(statisticVariable)
        if (statistic == "other") statistic <- tclvalue(otherVariable)
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        groups.list <- paste(paste(groups, "=", .activeDataSet, "$", groups, sep=""), collapse=", ")
        doItAndPrint(paste("tapply(", .activeDataSet, "$", response, ", list(", groups.list,
             "), ", statistic, ", na.rm=TRUE)", sep=""))
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="tapply")
    tkgrid(getFrame(groupBox), tklabel(variablesFrame, text="    "),getFrame(responseBox), sticky="nw")
    tkgrid(variablesFrame, sticky="w")
    tkgrid(statisticFrame, sticky="w")
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix(rows=3, columns=1, focus=otherEntry)
    }
    
correlationMatrix <- function(){
    if (!checkActiveDataSet()) return()
    if (!checkNumeric(2)) return()
    initializeDialog(title="Correlation Matrix")
    xBox <- variableListBox(top, .numeric, selectmode="multiple", title="Variables (pick two or more)")
    radioButtons(name="correlations", buttons=c("pearson", "spearman", "partial"), values=c("Pearson", "Spearman", "partial"),
        labels=c("Pearson product-moment", "Spearman rank-order", "Partial"), title="Type of Correlations")
    onOK <- function(){
        correlations <- tclvalue(correlationsVariable)
        x <- getSelection(xBox)
        if (2 > length(x)) {
            errorCondition(recall=correlationMatrix, message="Fewer than 2 variables selected.")
            return()
            }
        if ((correlations == "partial") && (3 > length(x))) {
            errorCondition(recall=correlationMatrix, message="Fewer than 3 variables selected\nfor partial correlations.")
            return()
            }
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        x <- paste('"', x, '"', sep="")
        if (correlations == "Pearson")
            doItAndPrint(paste("cor(", .activeDataSet, "[,c(", paste(x, collapse=","),
                ')], use="complete.obs")', sep=""))
        else if (correlations == "Spearman"){
            logger("# Spearman rank-order correlations")
             doItAndPrint(paste("cor(apply(", .activeDataSet, "[,c(", paste(x, collapse=","),
                ')], 2, rank), use="complete.obs")', sep="")) 
             }
        else doItAndPrint(paste("partial.cor(", .activeDataSet, "[,c(", paste(x, collapse=","),
                ')], use="complete.obs")', sep=""))    
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="cor")
    tkgrid(getFrame(xBox), sticky="nw")
    tkgrid(correlationsFrame, sticky="w")
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix(rows=3, columns=1)
    }
# Statistics Menu dialogs

# last modified 5 July 04 by J. Fox

    # Tables menu
    
twoWayTable <- function(){
    if (!checkActiveDataSet()) return()
    if (!checkFactors(2)) return()
    initializeDialog(title="Two-Way Table")
    variablesFrame <- tkframe(top)
    rowBox <- variableListBox(variablesFrame, .factors, title="Row variable (pick one)")
    columnBox <- variableListBox(variablesFrame, .factors, title="Column variable (pick one)")
    subsetBox()
    onOK <- function(){
        row <- getSelection(rowBox)
        column <- getSelection(columnBox)
        if (length(row) == 0 || length(column) == 0){
            errorCondition(recall=twoWayTable, message="You must select two variables.")
            return()
            }
        if (row == column) {
            errorCondition(recall=twoWayTable, message="Row and column variables are the same.")
            return()
            }        
        percents <- as.character(tclvalue(percentsVariable))
        chisq <- tclvalue(chisqTestVariable)
        expected <- tclvalue(expFreqVariable)
        fisher <- tclvalue(fisherTestVariable)
        subset <- tclvalue(subsetVariable)
        subset <- if (trim.blanks(subset) == "<all valid cases>") "" 
            else paste(", subset=", subset, sep="")
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        command <- paste("xtabs(~", row, "+", column, ", data=", .activeDataSet, 
            subset, ")", sep="")
        logger(paste(".Table <- ", command, sep=""))
        assign(".Table", justDoIt(command), envir=.GlobalEnv)
        doItAndPrint(".Table")
        if (percents == "row") doItAndPrint("rowPercents(.Table) # Row Percentages")
        if (percents == "column") doItAndPrint("colPercents(.Table) # Column Percentages")
        if (chisq == 1) {
            command <- "chisq.test(.Table, correct=FALSE)"
            logger(paste(".Test <- ", command, sep=""))
            assign(".Test", justDoIt(command), envir=.GlobalEnv)
            doItAndPrint(".Test")
            if (expected == 1) doItAndPrint(".Test$expected # Expected Counts")
            warnText <- NULL
            if (0 < (nlt1 <- sum(.Test$expected < 1))) warnText <- paste(nlt1,
                "expected frequencies are less than 1")
            if (0 < (nlt5 <- sum(.Test$expected < 1))) warnText <- paste(warnText, "\n", nlt5,
                " expected frequencies are less than 5", sep="")
            if (!is.null(warnText)) tkmessageBox(message=warnText,
                icon="warning", type="ok")
            logger("remove(.Test)") 
            remove(.Test, envir=.GlobalEnv) 
            }
        if (fisher == 1) doItAndPrint("fisher.test(.Table)")
        logger("remove(.Table)") 
        remove(.Table, envir=.GlobalEnv)                                                      
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="xtabs")
    radioButtons(name="percents", buttons=c("rowPercents", "columnPercents", "nonePercents"), 
        values=c("row", "column", "none"), initialValue="none", 
        labels=c("Row percentages", "Column percentages", "No percentages"), title="Compute Percentages")
    checkBoxes(frame="testsFrame", boxes=c("chisqTest", "expFreq", "fisherTest"), initialValues=c("1", "0", "0"),
        labels=c("Chisquare test of independence", "Print expected frequencies", "Fisher's exact test"))
    tkgrid(getFrame(rowBox), tklabel(variablesFrame, text="    "), getFrame(columnBox), sticky="nw")
    tkgrid(variablesFrame, sticky="w")
    tkgrid(percentsFrame, sticky="w")
    tkgrid(tklabel(top, text="Hypothesis Tests", fg="blue"), sticky="w")
    tkgrid(testsFrame, sticky="w")
    tkgrid(subsetFrame, sticky="w")
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix(rows=6, columns=1)
    }

multiWayTable <- function(){
    if (!checkActiveDataSet()) return()
    if (!checkFactors(3)) return()
    initializeDialog(title="Multi-Way Table")
    variablesFrame <- tkframe(top)
    rowBox <- variableListBox(variablesFrame, .factors, title="Row variable (pick one)")
    columnBox <- variableListBox(variablesFrame, .factors, title="Column variable (pick one)")
    controlBox <- variableListBox(variablesFrame, .factors, selectmode="multiple", 
        title="Control variable(s) (pick one or more)")
    subsetBox()
    onOK <- function(){
        row <- getSelection(rowBox)
        column <- getSelection(columnBox)
        controls <- getSelection(controlBox)
        if (length(row) == 0 || length(column) == 0 || length(controls) == 0) {
            errorCondition(recall=multiWayTable, message="You must select row, column, and control variables")
            return()
            }
        if ((row == column) || is.element(row, controls) || is.element(column, controls)) {
            errorCondition(recall=multiWayTable, message="Row, column, and control variables must be different.")
            return()
            }
        percents <- as.character(tclvalue(percentsVariable))
        subset <- tclvalue(subsetVariable)
        subset <- if (trim.blanks(subset) == "<all valid cases>") "" 
            else paste(", subset=", subset, sep="")
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        command <- paste("xtabs(~", row, "+", column, "+", paste(controls, collapse="+"),
            ", data=", .activeDataSet, subset, ")", sep="")
        logger(paste(".Table <- ", command, sep=""))
        assign(".Table", justDoIt(command), envir=.GlobalEnv)
        doItAndPrint(".Table")
        if (percents == "row") doItAndPrint("rowPercents(.Table) # Row Percentages")
        if (percents == "column") doItAndPrint("colPercents(.Table) # Column Percentages")
        logger("remove(.Table)") 
        remove(.Table, envir=.GlobalEnv)                                             
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="xtabs")
    radioButtons(name="percents", buttons=c("rowPercents", "columnPercents", "nonePercents"), values=c("row", "column", "none"),
        initialValue="none", labels=c("Row percentages", "Column percentages", "No percentages"), title="Compute Percentages")
    tkgrid(getFrame(rowBox), tklabel(variablesFrame, text="    "), getFrame(columnBox), tklabel(variablesFrame, text="    "), 
        getFrame(controlBox), sticky="nw")
    tkgrid(variablesFrame, sticky="w")
    tkgrid(percentsFrame, sticky="w")
    tkgrid(subsetFrame, sticky="w")
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix(rows=4, columns=1)
    }

enterTable <- function(){
    env <- environment()
    initializeDialog(title="Enter and Analyze Two-Way Table")
    outerTableFrame <- tkframe(top)
    assign(".tableFrame", tkframe(outerTableFrame), envir=env)
    setUpTable <- function(...){
        tkdestroy(get(".tableFrame", envir=env))
        assign(".tableFrame", tkframe(outerTableFrame), envir=env)
        nrows <- as.numeric(tclvalue(rowsValue))
        ncols <- as.numeric(tclvalue(colsValue))
        make.col.names <- "tklabel(.tableFrame, text='')"
        for (j in 1:ncols) {
            col.varname <- paste(".colname.", j, sep="")
            assign(col.varname, tclVar(j), envir=env)
            make.col.names <- paste(make.col.names, ", ", "tkentry(.tableFrame, width='5', textvariable=", 
                    col.varname, ")", sep="")
            }
        eval(parse(text=paste("tkgrid(", make.col.names, ")", sep="")), envir=env)
        for (i in 1:nrows){   
            varname <- paste(".tab.", i, ".1", sep="") 
            assign(varname, tclVar("") , envir=env)
            row.varname <- paste(".rowname.", i, sep="")
            assign(row.varname, tclVar(i), envir=env)
            make.row <- paste("tkentry(.tableFrame, width='5', textvariable=",
                row.varname, ")", sep="")
            make.row <- paste(make.row, ", ", "tkentry(.tableFrame, width='5', textvariable=", 
                varname, ")", sep="")
            for (j in 2:ncols){
                varname <- paste(".tab.", i, ".", j, sep="")
                assign(varname, tclVar(""), envir=env)
                make.row <- paste(make.row, ", ", "tkentry(.tableFrame, width='5', textvariable=", 
                    varname, ")", sep="")
                }
            eval(parse(text=paste("tkgrid(", make.row, ")", sep="")), envir=env)
            }
        tkgrid(get(".tableFrame", envir=env), sticky="w")
        }
    rowColFrame <- tkframe(top)
    rowsValue <- tclVar("2")
    rowsSlider <- tkscale(rowColFrame, from=2, to=10, showvalue=FALSE, variable=rowsValue,
        resolution=1, orient="horizontal", command=setUpTable)
    rowsShow <- tklabel(rowColFrame, textvariable=rowsValue, width=2, justify="right")
    colsValue <- tclVar("2")
    colsSlider <- tkscale(rowColFrame, from=2, to=10, showvalue=FALSE, variable=colsValue,
        resolution=1, orient="horizontal", command=setUpTable)
    colsShow <- tklabel(rowColFrame, textvariable=colsValue, width=2, justify="right")
    onOK <- function(){
        nrows <- as.numeric(tclvalue(rowsValue))
        ncols <- as.numeric(tclvalue(colsValue))
        cell <- 0
        counts <- rep(NA, nrows*ncols)
        row.names <- rep("", nrows)
        col.names <- rep("", ncols)
        for (i in 1:nrows) row.names[i] <- 
            eval(parse(text=paste("tclvalue(", paste(".rowname.", i, sep=""),")", sep="")))
        for (j in 1:ncols) col.names[j] <- 
            eval(parse(text=paste("tclvalue(", paste(".colname.", j, sep=""),")", sep="")))
        for (i in 1:nrows){
            for (j in 1:ncols){
                cell <- cell+1
                varname <- paste(".tab.", i, ".", j, sep="")
                counts[cell] <- as.numeric(eval(parse(text=paste("tclvalue(", varname,")", sep=""))))
                }
            }
        counts <- na.omit(counts)
        if (length(counts) != nrows*ncols){
            errorCondition(recall=enterTable, message=paste("Number of valid entries (", length(counts), ")\n",
                "not equal to number of rows (", nrows,") * number of columns (", ncols,").", sep=""))
            return()
            }
        if (length(unique(row.names)) != nrows){
            errorCondition(recall=enterTable, message="Row names are not unique.")
            return()
            }     
        if (length(unique(col.names)) != ncols){
            errorCondition(recall=enterTable, message="Column names are not unique.")
            return()
            }     
        percents <- as.character(tclvalue(percentsVariable))
        chisq <- tclvalue(chisqVariable)
        expected <- tclvalue(expFreqVariable)
        fisher <- tclvalue(fisherVariable)
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        command <- paste("matrix(c(", paste(counts, collapse=","), "), ", nrows, ", ", ncols,
            ", byrow=TRUE)", sep="")
        assign(".Table", justDoIt(command), envir=.GlobalEnv)
        logger(paste(".Table <- ", command, sep=""))
        command <- paste("c(",paste(paste("'", row.names, "'", sep=""), collapse=", "), ")", sep="")
        justDoIt(paste("rownames(.Table) <- ", command, sep=""))
        logger(paste("rownames(.Table) <- ", command, sep=""))
        command <- paste("c(",paste(paste("'", col.names, "'", sep=""), collapse=", "), ")", sep="")
        justDoIt(paste("colnames(.Table) <- ", command, sep=""))
        logger(paste("colnames(.Table) <- ", command, sep=""))
        doItAndPrint(".Table  # Counts")
        if (percents == "row") doItAndPrint("rowPercents(.Table) # Row Percentages")
        if (percents == "column") doItAndPrint("colPercents(.Table) # Column Percentages")
        if (chisq == 1) {
            command <- "chisq.test(.Table, correct=FALSE)"
            logger(paste(".Test <- ", command, sep=""))
            assign(".Test", justDoIt(command), envir=.GlobalEnv)
            doItAndPrint(".Test")
            if (expected == 1) doItAndPrint(".Test$expected # Expected Counts")
            warnText <- NULL
            if (0 < (nlt1 <- sum(.Test$expected < 1))) warnText <- paste(nlt1,
                "expected frequencies are less than 1")
            if (0 < (nlt5 <- sum(.Test$expected < 1))) warnText <- paste(warnText, "\n", nlt5,
                " expected frequencies are less than 5", sep="")
            if (!is.null(warnText)) tkmessageBox(message=warnText,
                icon="warning", type="ok")
            logger("remove(.Test)") 
            remove(.Test, envir=.GlobalEnv) 
            }
        if (fisher == 1) doItAndPrint("fisher.test(.Table)")
        logger("remove(.Table)") 
        remove(.Table, envir=.GlobalEnv)                                                      
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="chisq.test")
    radioButtons(name="percents", buttons=c("rowPercents", "columnPercents", "nonePercents"), values=c("row", "column", "none"),
        initialValue="none", labels=c("Row percentages", "Column percentages", "No percentages"), title="Compute Percentages")
    checkBoxes(frame="testsFrame", boxes=c("chisq", "expFreq", "fisher"), initialValues=c("1", "0", "0"),
        labels=c("Chisquare test of independence", "Print expected frequencies", "Fisher's exact test"))
    tkgrid(tklabel(rowColFrame, text="Number of Rows:"), rowsSlider, rowsShow, sticky="w")
    tkgrid(tklabel(rowColFrame, text="Number of Columns:"), colsSlider, colsShow, sticky="w")
    tkgrid(rowColFrame, sticky="w")
    tkgrid(tklabel(top, text="Enter counts:", fg="blue"), sticky="w")
    tkgrid(outerTableFrame, sticky="w")
    tkgrid(percentsFrame, sticky="w")
    tkgrid(tklabel(top, text="Hypothesis Tests", fg="blue"), sticky="w")
    tkgrid(testsFrame, sticky="w")
    tkgrid(buttonsFrame, columnspan=2, sticky="w")
    dialogSuffix(rows=7, columns=2)
    } 
# Statistics Menu dialogs

# last modified 13 July 04 by J. Fox

    # Variances menu
    
twoVariancesFTest <- function(){
    if (!checkActiveDataSet()) return()
    if (!checkNumeric()) return()
    if (!checkTwoLevelFactors()) return()
    initializeDialog(title="Two Variances F-Test")
    variablesFrame <- tkframe(top)
    groupBox <- variableListBox(variablesFrame, .twoLevelFactors, title="Groups (pick one)")
    responseBox <- variableListBox(variablesFrame, .numeric, title="Response Variable (pick one)")
    onOK <- function(){
        group <- getSelection(groupBox)
        if (length(group) == 0) {
            errorCondition(recall=twoVariancesFTest, message="You must select a groups variable.")
            return()
            }
        response <- getSelection(responseBox)
        if (length(response) == 0) {
            errorCondition(recall=twoVariancesFTest, message="You must select a response variable.")
            return()
            }
        alternative <- as.character(tclvalue(alternativeVariable))
        level <- tclvalue(confidenceLevel)
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        doItAndPrint(paste("tapply(", .activeDataSet, "$", response, ", ", 
            .activeDataSet, "$", group, ",  var, na.rm=TRUE)", sep=""))
        doItAndPrint(paste("var.test(", response, " ~ ", group,
            ", alternative='", alternative, "', conf.level=", level,
            ", data=", .activeDataSet, ")", sep=""))
        tkfocus(.commander)
        tkdestroy(top)
        }
    OKCancelHelp(helpSubject="var.test")
    radioButtons(name="alternative", buttons=c("twosided", "less", "greater"), values=c("two.sided", "less", "greater"),
        labels=c("Two-sided", "Difference < 0", "Difference > 0"), title="Alternative Hypothesis")
    confidenceFrame <- tkframe(top)
    confidenceLevel <- tclVar(".95")
    confidenceField <- tkentry(confidenceFrame, width="6", textvariable=confidenceLevel)
    tkgrid(getFrame(groupBox), tklabel(variablesFrame, text="    "), getFrame(responseBox), sticky="nw")
    tkgrid(variablesFrame, sticky="w")
    groupsLabel(groupsBox=groupBox)
    tkgrid(tklabel(confidenceFrame, text="Confidence Level:  ", fg="blue"), confidenceField, sticky="w")
    tkgrid(alternativeFrame, sticky="w")
    tkgrid(confidenceFrame, sticky="w")
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix(rows=5, columns=1)
    }

BartlettTest <- function(){
    if (!checkActiveDataSet()) return()
    if (!checkNumeric()) return()
    if (!checkFactors()) return()
    initializeDialog(title="Bartlett's Test")
    variableFrame <- tkframe(top)
    groupBox <- variableListBox(variableFrame, .factors, title="Groups (pick one)")
    responseBox <- variableListBox(variableFrame, .numeric, title="Response Variable (pick one)")
    onOK <- function(){
        group <- getSelection(groupBox)
        if (length(group) == 0) {
            errorCondition(recall=BartlettTest, message="You must select a groups variable.")
            return()
            }
        response <- getSelection(responseBox)
        if (length(response) == 0) {
            errorCondition(recall=BartlettTest, message="You must select a response variable.")
            return()
            }
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        doItAndPrint(paste("tapply(", paste(.activeDataSet, "$", response, sep=""),
            ", ", paste(.activeDataSet, "$", group, sep=""), ", var, na.rm=TRUE)", sep=""))
        doItAndPrint(paste("bartlett.test(", response, " ~ ", group, ", data=",
            .activeDataSet, ")", sep=""))
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="bartlett.test")
    tkgrid(getFrame(groupBox), tklabel(variableFrame, text="    "), getFrame(responseBox), sticky="nw")
    tkgrid(variableFrame, sticky="w")
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix(rows=2, columns=1)
    }

LeveneTest <- function(){
    if (!checkActiveDataSet()) return()
    if (!checkNumeric()) return()
    if (!checkFactors()) return()
    initializeDialog(title="Levene's Test")
    variableFrame <- tkframe(top)
    groupBox <- variableListBox(variableFrame, .factors, title="Groups (pick one)")
    responseBox <- variableListBox(variableFrame, .numeric, title="Response Variable (pick one)")
    onOK <- function(){
        group <- getSelection(groupBox)
        if (length(group) == 0) {
            errorCondition(recall=LeveneTest, message="You must select a groups variable.")
            return()
            }
        response <- getSelection(responseBox)
        if (length(response) == 0) {
            errorCondition(recall=LeveneTest, message="You must select a response variable.")
            return()
            }
        if (.grab.focus) tkgrab.release(top)
        tkdestroy(top)
        doItAndPrint(paste("tapply(", paste(.activeDataSet, "$", response, sep=""),
            ", ", paste(.activeDataSet, "$", group, sep=""), ", var, na.rm=TRUE)", sep=""))
        doItAndPrint(paste("levene.test(", paste(.activeDataSet, "$", response, sep=""), 
            ", ", paste(.activeDataSet, "$", group, sep=""), ")", sep=""))
        tkfocus(.commander)
        }
    OKCancelHelp(helpSubject="levene.test")
    tkgrid(getFrame(groupBox), tklabel(variableFrame, text="    "), getFrame(responseBox), sticky="nw")
    tkgrid(variableFrame, sticky="w")
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix(rows=2, columns=1)
    }
# last modified 15 Jan 05 by J. Fox + slight changes 12 Aug 04 by Ph. Grosjean

# utility functions

listDataSets <- function(envir=.GlobalEnv, ...) {
    names(which(sapply(ls(envir=envir, all.names=TRUE, ...), 
        function(.x) is.data.frame(eval(parse(text=.x), envir=envir)))))
    }

listLinearModels <- function(envir=.GlobalEnv, ...) {
    objects <- ls(envir=envir, ...)
    if (length(objects) == 0) NULL
    else objects[sapply(objects, 
        function(.x) "lm" == (class(eval(parse(text=.x), envir=envir))[1]))]
    }

listGeneralizedLinearModels <- function(envir=.GlobalEnv, ...) {
    objects <- ls(envir=envir, ...)
    if (length(objects) == 0) NULL
    else objects[sapply(objects, 
        function(.x) "glm" == (class(eval(parse(text=.x), envir=envir))[1]))]
    }

listMultinomialLogitModels <- function(envir=.GlobalEnv, ...) {
    objects <- ls(envir=envir, ...)
    if (length(objects) == 0) NULL
    else objects[sapply(objects, 
        function(.x) "multinom" == (class(eval(parse(text=.x), envir=envir))[1]))]
    }

listProportionalOddsModels <- function(envir=.GlobalEnv, ...) {
    objects <- ls(envir=envir, ...)
    if (length(objects) == 0) NULL
    else objects[sapply(objects, 
        function(.x) "polr" == (class(eval(parse(text=.x), envir=envir))[1]))]
    }

listAllModels <- function(envir=.GlobalEnv, ...) {
    objects <- ls(envir=envir, ...)
    if (length(objects) == 0) NULL
    else objects[sapply(objects, 
        function(.x) (class(eval(parse(text=.x), envir=envir))[1])) %in% .modelClasses]
    }
                
activeDataSet <- function(dsname, flushModel=TRUE){
    if (missing(dsname)) {
        if (is.null(.activeDataSet)){
            tkmessageBox(message="There is no active data set.", icon="error", type="ok")
            return(FALSE)
            }
        else return(.activeDataSet)
        }
    if (!is.data.frame(get(dsname, envir=.GlobalEnv))){
        tkmessageBox(message=paste(dsname, " is not a data frame and cannot be attached.",
            sep=""), icon="error", type="ok")
        tkfocus(.commander)
        return()
        }
    if (!is.null(.activeDataSet) && .attach.data.set
        && (length(grep(.activeDataSet, search())) !=0)) {
        detach(pos = match(.activeDataSet, search()))
        logger(paste("detach(", .activeDataSet, ")", sep=""))
        }
    if (flushModel) {
        assign(".activeModel", NULL, envir=.GlobalEnv)
        tclvalue(.modelName) <- "<No active model>"
        }
    # -PhG tkconfigure(.modelLabel, fg="red")
    assign(".activeDataSet", dsname, envir=.GlobalEnv)
    assign(".variables", listVariables(), envir=.GlobalEnv)
    assign(".numeric", listNumeric(), envir=.GlobalEnv)
    assign(".factors", listFactors(), envir=.GlobalEnv)
    assign(".twoLevelFactors", listTwoLevelFactors(), envir=.GlobalEnv)
    tclvalue(.dataSetName) <- paste(.activeDataSet, " ")
    # -PhG tkconfigure(.dataSetLabel, fg="blue")
    if (!is.SciViews()) tkconfigure(.dataSetLabel, fg="blue") else refreshStatus() # +PhG
    if (.attach.data.set){
        attach(get(dsname, envir=.GlobalEnv), name=dsname)
        logger(paste("attach(", dsname, ")", sep=""))
        }
    if (is.SciViews()) refreshStatus() else if (flushModel) tkconfigure(.modelLabel, fg="red") # +PhG (& J.Fox, 25Dec04)
    dsname
    }


activeModel <- function(model){
    if (missing(model)) {
        if (is.null(.activeModel)){
            tkmessageBox(message="There is no active model.", icon="error", type="ok")
            return(FALSE)
            }
        else return(.activeModel)
        }
    assign(".activeModel", model, envir=.GlobalEnv)
    tclvalue(.modelName) <- .activeModel
    # -PhG tkconfigure(.modelLabel, fg="blue")
    if (!is.SciViews()) tkconfigure(.modelLabel, fg="blue") else refreshStatus() # +PhG
    model
    }
    
listVariables <- function(dataSet=.activeDataSet) {
    vars <- eval(parse(text=paste("names(", dataSet,")")), envir=.GlobalEnv)
    if (.sort.names) sort(vars) else vars
    }

listFactors <- function(dataSet=.activeDataSet) {
    variables <- if (exists(".variables")) .variables else listVariables(dataSet)
    variables[sapply(variables, function(.x)
        is.factor(eval(parse(text=.x), envir=eval(parse(text=dataSet), envir=.GlobalEnv))))]
    }

listTwoLevelFactors <- function(dataSet=.activeDataSet){
    factors <- listFactors(dataSet)
    if(length(factors) == 0) return(NULL)
    factors[sapply(factors, function(.x)
        2 == length(levels(eval(parse(text=.x), envir=eval(parse(text=dataSet), 
            envir=.GlobalEnv)))))]
    }
    
listNumeric <- function(dataSet=.activeDataSet) {
    variables <- if (exists(".variables")) .variables else listVariables(dataSet)
    variables[sapply(variables,function(.x)
        is.numeric(eval(parse(text=.x), envir=eval(parse(text=dataSet), envir=.GlobalEnv))))]
    }

trim.blanks <- function(text){
    gsub("^\ ", "", gsub("\ *$", "", text))
    }
    
is.valid.name <- function(x){
    length(x) == 1 && is.character(x) && x == make.names(x)
    }

    
    # statistical
    
colPercents <- function(tab, digits=1){
    dim <- length(dim(tab))
    if (is.null(dimnames(tab))){
        dims <- dim(tab)
        dimnames(tab) <- lapply(1:dim, function(i) 1:dims[i])
        }
    sums <- apply(tab, 2:dim, sum)
    per <- apply(tab, 1, function(x) x/sums)
    dim(per) <- dim(tab)[c(2:dim,1)]
    per <- aperm(per, c(dim, 1:(dim-1)))
    dimnames(per) <- dimnames(tab)
    per <- round(100*per, digits)
    result <- abind(per, Total=apply(per, 2:dim, sum), Count=sums, along=1)
    names(dimnames(result)) <- names(dimnames(tab))
    result
    }

rowPercents <- function(tab, digits=1){
    dim <- length(dim(tab))
    if (dim == 2) return(t(colPercents(t(tab), digits=digits)))
    tab <- aperm(tab, c(2,1,3:dim))
    aperm(colPercents(tab, digits=digits), c(2,1,3:dim))
    }

reliability <- function(S){
    reliab <- function(S, R){
        k <- dim(S)[1]
        ones <- rep(1, k)
        v <- as.vector(ones %*% S %*% ones)
        alpha <- (k/(k - 1)) * (1 - (1/v)*sum(diag(S)))
        rbar <- mean(R[lower.tri(R)])
        std.alpha <- k*rbar/(1 + (k - 1)*rbar)
        c(alpha=alpha, std.alpha=std.alpha)
        }
    result <- list()
    if ((!is.numeric(S)) || !is.matrix(S) || (nrow(S) != ncol(S)) 
        || any(abs(S - t(S)) > max(abs(S))*1e-10) || nrow(S) < 2)
        stop("argument must be a square, symmetric, numeric covariance matrix")
    k <- dim(S)[1]
    s <- sqrt(diag(S))
    R <- S/(s %o% s)
    rel <- reliab(S, R)
    result$alpha <- rel[1]
    result$st.alpha <- rel[2]
    if (k < 3) {
        warning("there are fewer than 3 items in the scale")
        return(invisible(NULL))
        }
    rel <- matrix(0, k, 3)
    for (i in 1:k) {
        rel[i, c(1,2)] <- reliab(S[-i, -i], R[-i, -i])
        a <- rep(0, k)
        b <- rep(1, k)
        a[i] <- 1
        b[i] <- 0
        cov <- a %*% S %*% b
        var <- b %*% S %*% b
        rel[i, 3] <- cov/(sqrt(var * S[i,i]))
        }
    rownames(rel) <- rownames(S)
    colnames(rel) <- c("Alpha", "Std.Alpha", "r(item, total)")
    result$rel.matrix <- rel
    class(result) <- "reliability"
    result
    }

print.reliability <- function(x, digits=4, ...){
    cat(paste("Alpha reliability = ", round(x$alpha, digits), "\n"))
    cat(paste("Standardized alpha = ", round(x$st.alpha, digits), "\n"))
    cat("\nReliability deleting each item in turn:\n")
    print(round(x$rel.matrix, digits))
    invisible(x)
    }
    
partial.cor <- function(X, ...){
    R <- cor(X, ...)
    RI <- solve(R)
    D <- 1/sqrt(diag(RI))
    R <- - RI * (D %o% D)
    diag(R) <- 0
    rownames(R) <- colnames(R) <- colnames(X)
    R
    }


    # wrapper function for histograms

Hist <- function(x, scale=c("frequency", "percent", "density"), ...){
    xlab <- deparse(substitute(x))
    x <- na.omit(x)
    scale <- match.arg(scale)
    if (scale == "frequency") hist(x, xlab=xlab, main="",  ...)
    else if (scale == "density") hist(x, freq=FALSE, xlab=xlab, main="", ...)
    else {
        n <- length(x)
        hist(x, axes=FALSE, xlab=xlab, ylab="Percent", main="", ...)
        axis(1)
        max <- ceiling(10*par("usr")[4]/n)
        at <- if (max <= 3) (0:(2*max))/20
                else (0:max)/10
        axis(2, at=at*n, labels=at*100)
        }  
    box()   
    abline(h=0, col="gray") 
    invisible(NULL)
    }

stem.leaf <- function(data, unit, m, Min, Max, rule.line=c("Dixon", "Velleman", "Sturges"),
     style=c("Tukey", "bare"), trim.outliers=TRUE, depths=TRUE, reverse.negative.leaves=TRUE){
#Author:  Peter Wolf 05/2003  (modified slightly by J. Fox, 20 July 03)
    rule.line <- match.arg(rule.line)
    style <- match.arg(style)
    n <- length(data<-sort(data))
    row.max <- floor(  c(Dixon   =10*log(n,10),
                        Velleman=2*sqrt(n),
                        Sturges =1+log(n,2)        ))[rule.line]
    stats <- boxplot(data, plot=FALSE)
    if(missing(Min)) Min <- if (trim.outliers) stats$stats[1,1] else min(data, na.rm=TRUE)
    if(missing(Max)) Max <- if (trim.outliers) stats$stats[5,1] else max(data, na.rm=TRUE)
    spannweite.red <- Max - Min
    zeilen.intervall.laenge<-spannweite.red / row.max
    factor <- if(missing(unit)) 10^ceiling(log(zeilen.intervall.laenge,10))
                else 10^round(log(unit*10,10))
    z <- zeilen.intervall.laenge/factor  # z in (0.1 ,1]
    delta.tick <- c(.2,.2,.5,1)[sum(z > c(0,.1,.2,.5))]
    if(missing(m)) m <- round(1/delta.tick) else delta.tick <- 1/m
    data.tr <- data/factor
    Min.tr <- Min/factor
    Max.tr <- Max/factor
    spannweite.red <- Max.tr - Min.tr
    sk.min <-  floor(Min.tr)
    sk.max <- ceiling(Max.tr)
    skala <- seq(sk.min, sk.max, by=delta.tick)
    if(sk.min < 0) skala <- c(sk.min-delta.tick, skala)
    if(sk.max < 0) skala <- skala[-length(skala)]
    lo.limit <- if (trim.outliers) skala[1] else -Inf
    lo.log   <- if(skala[1] <  0) data.tr <= lo.limit else data.tr <  lo.limit
    n.sk <- length(skala)
    hi.limit <- if (trim.outliers) skala[n.sk] + delta.tick else Inf
    hi.log   <- if(skala[n.sk] >= 0) data.tr >= hi.limit else data.tr >  hi.limit
    n.lower.extr.values <- sum(lo.log); n.upper.extr.values <- sum(hi.log)
    if(0 < n.lower.extr.values){
        lower.line<- paste("LO:", paste(data[lo.log],collapse=" "))
        }
    if(0 < n.upper.extr.values){
        upper.line<- paste("HI:", paste(data[hi.log],collapse=" "))
        }
    data.tr.red <-data.tr[(!lo.log)&(!hi.log)]
    stem <- ifelse(data.tr.red < 0, ceiling(data.tr.red), floor(data.tr.red) )
    leaf <- floor(abs(data.tr.red*10 - stem*10))
    class.of.data.tr <- unlist(c(
        sapply(data.tr.red[data.tr.red < 0],
            function(x, sk) length(sk) - sum(-sk <= -x), skala)
            ,sapply(data.tr.red[data.tr.red>=0],
            function(x,sk) sum(sk <= x), skala)
        ))
    class.of.data.tr  <- c(1:length(skala), class.of.data.tr)
    class.negative <- skala < 0
    leaf.grouped      <- split(c(rep(-1, length(skala)), leaf), class.of.data.tr)
    leaf.grouped      <- lapply(leaf.grouped, function(x){ sort(x[-1]) })
    if (reverse.negative.leaves){
        for (i in seq(class.negative))
            if (class.negative[i]) leaf.grouped[[i]] <- rev(leaf.grouped[[i]])
        }
    leaf.grouped.ch <- paste("|",unlist(lapply(leaf.grouped,paste,collapse="")))
    class.neg.zero <- floor(skala) == -1
    line.names <- skala
    line.names[class.negative] <- line.names[class.negative] + 1
    line.names <- as.character(floor(line.names))
    line.names[class.neg.zero] <- "-0"
    if(style=="Tukey"){
        switch(as.character(m),
        "1"={},
        "2"={
                h<-round(2*(skala%%1)) #; line.names[h!=0] <- ""
                line.names<-paste(line.names,
                        ifelse(skala<0,c(".","*")[1+h],c("*",".")[1+h]),sep="")
            },
        "5"={
                h<-round(5*(skala%%1)); line.names[h>0 & h<4] <- ""
                line.names<-paste(line.names, ifelse(skala<0,
                                c(".","s","f","t","*")[1+h],
                                c("*","t","f","s",".")[1+h]), sep="")
            }
            )
        }
    ragged.left<-function(ch.lines){
        max.n <-max(n.lines<-nchar(ch.lines))
        h     <-paste(rep(" ",max.n),collapse="")
        ch.lines <-paste( substring(h,1,1+max.n-n.lines), ch.lines)
        ch.lines
        }
    line.names <- ragged.left(line.names)
    n.class <- unlist(lapply(leaf.grouped, length))
    select <- (cumsum(n.class) > 0) & rev((cumsum(rev(n.class)) > 0))
    depth    <-    cumsum(n.class)          + n.lower.extr.values
    depth.rev <- rev(cumsum(rev(n.class))     + n.upper.extr.values)
    uplow <- depth >= depth.rev
    pos.median <- which(uplow)[1] + (-1:0)
    h <- abs(depth[pos.median]-depth.rev[pos.median])
    pos.median <- pos.median[1]+(h[1]>h[2])
    depth[uplow] <- depth.rev[uplow]
    depth <- paste(depth,"")
    depth[pos.median] <- paste("(",n.class[pos.median],")",sep="")
    depth[n.class == 0] <- " "
    depth <- if (depths) ragged.left(depth) else ""
    info<-     c(  paste("1 | 2: represents",1.2*factor),
                paste(" leaf unit:",factor/10),
                paste("         n:",n     ),
                "")
    stem <- paste(depth, line.names, leaf.grouped.ch)
    if ((style != "Tukey") || (m != 5) || (sum(select) > 4)) stem <- stem[select]
    if(exists("lower.line")) stem <- c(lower=lower.line, stem)
    if(exists("upper.line")) stem <- c(stem, upper=upper.line)
    result <- list(info=info, stem=stem)
    class(result) <- "stem.leaf"
    result
    }
    
print.stem.leaf <- function(x, ...){
    for(i in seq(x)) cat(x[[i]],sep="\n")
    invisible(x)
    }

plotMeans <- function(response, factor1, factor2, error.bars = c("se", "sd", "conf.int", "none"),
    level=0.95, xlab=deparse(substitute(factor1)), ylab=paste("mean of", deparse(substitute(response))), 
    legend.lab=deparse(substitute(factor2)), main="Plot of Means",
    pch=1:n.levs.2, lty=1:n.levs.2, col=palette()){
    if (!is.numeric(response)) stop("Argument response must be numeric.")
    xlab # force evaluation
    ylab
    legend.lab
    error.bars <- match.arg(error.bars)
    if (missing(factor2)){
        if (!is.factor(factor1)) stop("Argument factor1 must be a factor.")
        valid <- !(is.na(factor1) | is.na(response))
        factor1 <- factor1[valid]
        response <- response[valid]
        means <- tapply(response, factor1, mean)
        sds <- tapply(response, factor1, sd)
        ns <- tapply(response, factor1, length)
        if (error.bars == "se") sds <- sds/sqrt(ns)
        if (error.bars == "conf.int") sds <- qt((1 - level)/2, df=ns - 1, lower.tail=FALSE) * sds/sqrt(ns)
        yrange <-  if (error.bars != "none") c( min(means - sds), max(means + sds)) else range(means)
        levs <- levels(factor1)
        n.levs <- length(levs)
        plot(c(1, n.levs), yrange, type="n", xlab=xlab, ylab=ylab, axes=FALSE, main=main)
        points(1:n.levs, means, type="b", pch=16, cex=2)
        box()
        axis(2)
        axis(1, at=1:n.levs, labels=levs)
        if (error.bars != "none") arrows(1:n.levs, means - sds, 1:n.levs, means + sds, 
            angle=90, lty=2, code=3, length=0.125)
        }
    else {
        if (!(is.factor(factor1) | is.factor(factor2))) stop("Arguments factor1 and factor2 must be factors.")
        valid <- !(is.na(factor1) | is.na(factor2) | is.na(response))
        factor1 <- factor1[valid]
        factor2 <- factor2[valid]
        response <- response[valid]
        means <- tapply(response, list(factor1, factor2), mean)
        sds <- tapply(response, list(factor1, factor2), sd)
        ns <- tapply(response, list(factor1, factor2), length)
        if (error.bars == "se") sds <- sds/sqrt(ns)
        if (error.bars == "conf.int") sds <- qt((1 - level)/2, df=ns - 1, lower.tail=FALSE) * sds/sqrt(ns)
        yrange <-  if (error.bars != "none") c( min(means - sds), max(means + sds)) else range(means)
        levs.1 <- levels(factor1)
        levs.2 <- levels(factor2)
        n.levs.1 <- length(levs.1)
        n.levs.2 <- length(levs.2)
        if (n.levs.2 > length(col)) stop(paste("Number of groups for factor2, ", n.levs.2,
            ", exceeds number of distinct colours, ", length(col), ".", sep=""))
        plot(c(1, n.levs.1 + 1), yrange, type="n", xlab=xlab, ylab=ylab, axes=FALSE, main=main)
        box()
        axis(2)
        axis(1, at=1:n.levs.1, labels=levs.1)
        for (i in 1:n.levs.2){
            points(1:n.levs.1, means[, i], type="b", pch=pch[i], cex=2, col=col[i], lty=lty[i])
            if (error.bars != "none") arrows(1:n.levs.1, means[, i] - sds[, i], 
                1:n.levs.1, means[, i] + sds[, i], angle=90, code=3, col=col[i], lty=lty[i], length=0.125)
            }
        x.posn <- n.levs.1 + 0.25
        y.posn <- sum(c(0.1, 0.9) * par("usr")[c(3,4)])
        text(x.posn, y.posn, legend.lab, adj=c(0, -.5))
        legend(x.posn, y.posn, levs.2, pch=pch, col=col, lty=lty)
        }
    invisible(NULL)
    }

bin.var <- function (x, bins=4, method=c("intervals", "proportions", "natural"), labels=FALSE){
    method <- match.arg(method)
# Author: Dan Putler (revision by J. Fox, 5 Dec 04)
    if(length(x) < bins) {
      stop("The number of bins exceeds the number of data values")
        }
    x <- if(method == "intervals") cut(x, bins, labels=labels)
        else if (method == "proportions") cut(x, quantile(x, probs=seq(0,1,1/bins), na.rm=TRUE),
            include.lowest = TRUE, labels=labels)
        else {
            xx <- na.omit(x)
            breaks <- c(min(xx), tapply(xx, KMeans(xx, bins)$cluster, max))
            cut(x, breaks, include.lowest=TRUE, labels=labels)
            }
    as.factor(x)
    }
    
# 3D scatterplots via rgl

scatter3d <- function(x, y, z, xlab=deparse(substitute(x)), ylab=deparse(substitute(y)),
                      zlab=deparse(substitute(z)), revolutions=0, bg.col=c("black", "white"), axis.col=NULL,
                      surface.col=c("blue", "green", "orange", "magenta", "cyan", "red", "yellow", "gray"), 
                      neg.res.col="red", pos.res.col="green", point.col="yellow",
                      text.col=axis.col, grid.col=if (bg.col == "white") "black" else "gray", 
                      fogtype=c("exp2", "linear", "exp", "none"), 
                      residuals=(length(fit) == 1), surface=TRUE, grid=TRUE, df.smooth=NULL, df.additive=NULL,
                      sphere.size=1, threshold=0.01, speed=1, fov=60, 
                      fit="linear", groups=NULL, parallel=TRUE, model.summary=FALSE){
    require(rgl)
    require(mgcv)
    summaries <- list()
    if ((!is.null(groups)) && (nlevels(groups) > length(surface.col))) stop(paste("Number of groups (", 
        nlevels(groups), ") exceeds number of colors (", length(surface.col), ").", sep=""))
    if ((!is.null(groups)) && (!is.factor(groups))) stop("groups variable must be a factor.")
    bg.col <- match.arg(bg.col)
    fogtype <- match.arg(fogtype)
    if ((length(fit) > 1) && residuals && surface)
        stop("cannot plot both multiple surfaces and residuals")
    if (is.null(axis.col)) axis.col <- if (bg.col == "white") "black" else "white"
    xlab
    ylab
    zlab
    rgl.clear()
    rgl.viewpoint(fov=fov)
    rgl.bg(col=bg.col, fogtype=fogtype)
    valid <- if (is.null(groups)) !(is.na(x) | is.na(y) | is.na(z))
        else !(is.na(x) | is.na(y) | is.na(z) | is.na(groups))
    x <- x[valid]
    y <- y[valid]
    z <- z[valid]
    if (!is.null(groups)) groups <- groups[valid]
    x <- (x - min(x))/(max(x) - min(x))
    y <- (y - min(y))/(max(y) - min(y))
    z <- (z - min(z))/(max(z) - min(z))
    size <- sphere.size*((100/length(x))^(1/3))*0.015
    if (is.null(groups)){
        if (size > threshold) rgl.spheres(x, y, z, color=point.col, radius=size)
            else rgl.points(x, y, z, color=point.col)
            }
    else {
        if (size > threshold) rgl.spheres(x, y, z, color=surface.col[as.numeric(groups)], radius=size)
            else rgl.points(x, y, z, color=surface.col[as.numeric(groups)])
            }    
    rgl.lines(c(0,1), c(0,0), c(0,0), color=axis.col)
    rgl.lines(c(0,0), c(0,1), c(0,0), color=axis.col)
    rgl.lines(c(0,0), c(0,0), c(0,1), color=axis.col)
    rgl.texts(1, 0, 0, xlab, justify="right", color=text.col)
    rgl.texts(0, 1, 0, ylab, justify="right", color=text.col)
    rgl.texts(0, 0, 1, zlab, justify="right", color=text.col)
    if (surface){
        for (i in 1:length(fit)){
            f <- match.arg(fit[i], c("linear", "quadratic", "smooth", "additive"))
            vals <- seq(0, 1, length=26)
            dat <- expand.grid(x=vals, z=vals)
            if (is.null(groups)){
                mod <- switch(f,
                    linear = lm(y ~ x + z),
                    quadratic = lm(y ~ (x + z)^2 + I(x^2) + I(z^2)),
                    smooth = if (is.null(df.smooth)) gam(y ~ s(x, z))
                        else gam(y ~ s(x, z, fx=TRUE, k=df.smooth)),
                    additive = if (is.null(df.additive)) gam(y ~ s(x) + s(z))
                        else gam(y ~ s(x, fx=TRUE, k=df.additive[1]+1) + 
                            s(z, fx=TRUE, k=(rev(df.additive+1)[1]+1)))
                    )
                if (model.summary) summaries[[f]] <- summary(mod)
                yhat <- matrix(predict(mod, newdata=dat), 26, 26)
                rgl.surface(vals, vals, yhat, color=surface.col[i], alpha=0.5, lit=FALSE)
                if(grid) rgl.surface(vals, vals, yhat, color=grid.col, alpha=0.5, lit=FALSE, front="lines", back="lines")
                if (residuals){
                    n <- length(y)
                    fitted <- fitted(mod)
                    colors <- ifelse(residuals(mod) > 0, pos.res.col, neg.res.col)
                    rgl.lines(as.vector(rbind(x,x)), as.vector(rbind(y,fitted)), as.vector(rbind(z,z)),
                        color=as.vector(rbind(colors,colors)))
                    }
                }
            else{
                if (parallel){
                    mod <- switch(f,
                        linear = lm(y ~ x + z + groups),
                        quadratic = lm(y ~ (x + z)^2 + I(x^2) + I(z^2) + groups),
                        smooth = if (is.null(df.smooth)) gam(y ~ s(x, z) + groups)
                            else gam(y ~ s(x, z, fx=TRUE, k=df.smooth) + groups),
                        additive = if (is.null(df.additive)) gam(y ~ s(x) + s(z) + groups)
                            else gam(y ~ s(x, fx=TRUE, k=df.additive[1]+1) + 
                                s(z, fx=TRUE, k=(rev(df.additive+1)[1]+1)) + groups)
                        )
                    if (model.summary) summaries[[f]] <- summary(mod)
                    levs <- levels(groups)
                    for (j in 1:length(levs)){
                        group <- levs[j]
                        select.obs <- groups == group
                        yhat <- matrix(predict(mod, newdata=cbind(dat, groups=group)), 26, 26)
                        rgl.surface(vals, vals, yhat, color=surface.col[j], alpha=0.5, lit=FALSE)
                        if (grid) rgl.surface(vals, vals, yhat, color=grid.col, alpha=0.5, lit=FALSE, front="lines", back="lines")
                        rgl.texts(0, predict(mod, newdata=data.frame(x=0, z=0, groups=group)), 0, 
                            paste(group, " "), justify="right", color=surface.col[j])
                        if (residuals){
                            yy <- y[select.obs]
                            xx <- x[select.obs]
                            zz <- z[select.obs]
                            fitted <- fitted(mod)[select.obs]
                            rgl.lines(as.vector(rbind(xx,xx)), as.vector(rbind(yy,fitted)), as.vector(rbind(zz,zz)),
                                col=surface.col[j])
                            }
                        }
                    }
                else {
                    levs <- levels(groups)
                    for (j in 1:length(levs)){
                        group <- levs[j]
                        select.obs <- groups == group
                        mod <- switch(f,
                            linear = lm(y ~ x + z, subset=select.obs),
                            quadratic = lm(y ~ (x + z)^2 + I(x^2) + I(z^2), subset=select.obs),
                            smooth = if (is.null(df.smooth)) gam(y ~ s(x, z), subset=select.obs)
                                else gam(y ~ s(x, z, fx=TRUE, k=df.smooth), subset=select.obs),
                            additive = if (is.null(df.additive)) gam(y ~ s(x) + s(z), subset=select.obs)
                                else gam(y ~ s(x, fx=TRUE, k=df.additive[1]+1) + 
                                    s(z, fx=TRUE, k=(rev(df.additive+1)[1]+1)), subset=select.obs)
                            )
                        if (model.summary) summaries[[paste(f, ".", group, sep="")]] <- summary(mod)
                        yhat <- matrix(predict(mod, newdata=dat), 26, 26)
                        rgl.surface(vals, vals, yhat, color=surface.col[j], alpha=0.5, lit=FALSE)
                        rgl.surface(vals, vals, yhat, color=grid.col, alpha=0.5, lit=FALSE, front="lines", back="lines")
                        rgl.texts(0, predict(mod, newdata=data.frame(x=0, z=0, groups=group)), 0, 
                            paste(group, " "), justify="right", color=surface.col[j])
                        if (residuals){
                            yy <- y[select.obs]
                            xx <- x[select.obs]
                            zz <- z[select.obs]
                            fitted <- fitted(mod)
                            rgl.lines(as.vector(rbind(xx,xx)), as.vector(rbind(yy,fitted)), as.vector(rbind(zz,zz)),
                                col=surface.col[j])
                            }
                        }
                    }
                }    
            }
        }
    if (revolutions > 0) {
        for (i in 1:revolutions){
            for (angle in seq(1, 360, length=360/speed)) rgl.viewpoint(-angle, fov=fov)
            }
        }
    if (model.summary) return(summaries) else return(invisible(NULL))
    }


    # Pager

# this is slightly modified from tkpager to use the Rcmdr monospaced font
#   and a white background
    
RcmdrPager <- function (file, header, title, delete.file) 
{
    for (i in seq(along = file)) {
        zfile <- file[[i]]
        tt <- tktoplevel()
        tkwm.title(tt, if (length(title)) 
            title[(i - 1)%%length(title) + 1]
        else "")
        txt <- tktext(tt, bg = "white", font = .logFont)
        scr <- tkscrollbar(tt, repeatinterval = 5, command = function(...) tkyview(txt, 
            ...))
        tkconfigure(txt, yscrollcommand = function(...) tkset(scr, 
            ...))
        tkpack(txt, side = "left", fill = "both", expand = TRUE)
        tkpack(scr, side = "right", fill = "y")
        chn <- tkcmd("open", zfile)
        tkinsert(txt, "end", header[[i]])
        tkinsert(txt, "end", gsub("_\b", "", tclvalue(tkcmd("read", 
            chn))))
        tkcmd("close", chn)
        tkconfigure(txt, state = "disabled")
        tkmark.set(txt, "insert", "0.0")
        tkfocus(txt)
        if (delete.file) 
            tkcmd("file", "delete", zfile)
    }
}

    # help functions
    

    
helpCommander <- function() {
    if (as.numeric(R.Version()$major) >= 2) print(help("Commander"))
    else help("Commander")
    }

helpAboutCommander <- function() {
    if (as.numeric(R.Version()$major) >= 2) print(help("aboutRcmdr"))
    else help("aboutRcmdr")
    }

browseManual <- function() {
    browseURL(paste(file.path(.path.package(package="Rcmdr")[1], "doc"), 
        "/Getting-Started-with-the-Rcmdr.pdf", sep=""))
    }


    
    # functions for building dialog boxes
    
# the following function is slightly modified from Thomas Lumley, 
#   "Programmer's Niche: Macros in R," R-News, Sept. 2001, Vol. 1, No. 3, pp.11-13.
defmacro <- function(..., expr){
    expr <- substitute(expr)
    len <- length(expr)
    expr[3:(len+1)] <- expr[2:len]
    ## delete "macro" variables starting in ..
    expr[[2]] <- quote(on.exit(remove(list=objects(pattern="^\\.\\.", all.names=TRUE))))
    a <- substitute(list(...))[-1]
    ## process the argument list
    nn <- names(a)
    if (is.null(nn)) nn <- rep("", length(a))
    for (i in seq(length=length(a))){
        if (nn[i] == "") {
            nn[i] <- paste(a[[i]])
            msg <- paste(a[[i]], "not supplied")
            a[[i]] <- substitute(stop(foo), list(foo = msg))
            }
        }
    names(a) <- nn
    a <- as.list(a)
    ff <- eval(substitute(
        function(){
            tmp <- substitute(body)
            eval(tmp, parent.frame())
            },
        list(body = expr)))
    ## add the argument list
    formals(ff) <- a
    ## create a fake source attribute
    mm <- match.call()
    mm$expr <- NULL
    mm[[1]] <- as.name("macro")
    expr[[2]] <- NULL # get "local" variable removal out of source
    attr(ff, "source") <- c(deparse(mm), deparse(expr))
    ## return the macro
    ff
    }

OKCancelHelp <- defmacro(window=top, helpSubject=NULL, model=FALSE,
    expr={
        buttonsFrame <- tkframe(window, borderwidth=5)
        OKbutton <- tkbutton(buttonsFrame, text="OK", fg="darkgreen", width="12", command=onOK, default="active",
            borderwidth=3)
        onCancel <- function() {
            if (model) assign(".modelNumber", .modelNumber - 1, envir=.GlobalEnv)               
            if (.grab.focus) tkgrab.release(window)
            tkdestroy(window)  
            tkfocus(.commander)
            }
        cancelButton <- tkbutton(buttonsFrame, text="Cancel", fg="red", width="12", command=onCancel, borderwidth=3)
        if (!is.null(helpSubject)){
            onHelp <- function() {
                if (.grab.focus && .Platform$OS.type != "windows") tkgrab.release(window)
                if (as.numeric(R.Version()$major) >= 2) print(help(helpSubject))
                else help(helpSubject)
                }
            helpButton <- tkbutton(buttonsFrame, text="Help", width="12", command=onHelp, borderwidth=3)
            }       
        tkgrid(OKbutton, tklabel(buttonsFrame, text="  "), cancelButton, tklabel(buttonsFrame, text="            "), 
            if (!is.null(helpSubject)) helpButton, sticky="w")
        })

subOKCancelHelp <- defmacro(window=subdialog, helpSubject=NULL,
    expr={
        subButtonsFrame <- tkframe(window, borderwidth=5)
        subOKbutton <- tkbutton(subButtonsFrame, text="OK", fg="darkgreen", width="12", command=onOKsub, default="active",
            borderwidth=3)
        onCancelSub <- function() {
            if (.grab.focus) tkgrab.release(window)
            tkdestroy(window)  
            tkfocus(.commander)
            }
        subCancelButton <- tkbutton(subButtonsFrame, text="Cancel", fg="red", width="12", command=onCancelSub, 
            borderwidth=3)
        if (!is.null(helpSubject)){
            onHelpSub <- function(){
                if (.grab.focus && .Platform$OS.type != "windows") tkgrab.release(window)
                if (as.numeric(R.Version()$major) >= 2) print(help(helpSubject))
                else help(helpSubject)
                }
            subHelpButton <- tkbutton(subButtonsFrame, text="Help", width="12", command=onHelpSub, borderwidth=3)
            }       
        tkgrid(subOKbutton, tklabel(subButtonsFrame, text="  "), subCancelButton, 
            tklabel(subButtonsFrame, text="            "), if (!is.null(helpSubject)) subHelpButton, sticky="w")
        })

checkActiveDataSet <- function(){
    if (activeDataSet() == FALSE) {
        tkfocus(.commander)
        FALSE
        }
    else TRUE
    }
    
checkActiveModel <- function(){
    if (activeModel() == FALSE) {
        tkfocus(.commander)
        FALSE
        }
    else TRUE
    }
    
checkFactors <- function(n=1){
    if (length(.factors) < n){
        if (n > 1)
            tkmessageBox(message=paste("There fewer than", n, "factors in the active data set."), 
                    icon="error", type="ok")
        else tkmessageBox(message="There are no factors in the active data set.", 
                    icon="error", type="ok")
        tkfocus(.commander)
        FALSE
        }
    else TRUE
    }
    
checkTwoLevelFactors <- function(n=1){
    if (length(.twoLevelFactors) < n){
        if (n > 1)
            tkmessageBox(message=paste("There fewer than", n, "two-level factors in the active data set."), 
                    icon="error", type="ok")
        else tkmessageBox(message="There are no two-level factors in the active data set.", 
                    icon="error", type="ok")
        tkfocus(.commander)
        FALSE
        }
    else TRUE
    }
    
checkNumeric <- function(n=1){
    if (length(.numeric) < n){
        if (n > 1)
            tkmessageBox(message=paste("There fewer than", n, "numeric variables in the active data set."), 
                    icon="error", type="ok")
        else tkmessageBox(message="There are no numeric variables in the active data set.", 
                    icon="error", type="ok")
        tkfocus(.commander)
        FALSE
        }
    else TRUE
    }
    
checkVariables <- function(n=1){
    if (length(.variables) < n){
        if (n > 1)
            tkmessageBox(message=paste("There fewer than", n, "variables in the active data set."), 
                    icon="error", type="ok")
        else tkmessageBox(message="There are no variables in the active data set.", 
                    icon="error", type="ok")
        tkfocus(.commander)
        FALSE
        }
    else TRUE
    }

initializeDialog <- defmacro(window=top, title="", 
    expr={
        window <- tktoplevel(borderwidth=10)
        tkwm.title(window, title)
        }
    )

dialogSuffix <- defmacro(window=top, onOK=onOK, rows=1, columns=1, focus=top,
    bindReturn=TRUE, preventGrabFocus=FALSE,
    expr={
        for (row in 0:(rows-1)) tkgrid.rowconfigure(window, row, weight=0)
        for (col in 0:(columns-1)) tkgrid.columnconfigure(window, col, weight=0)
        .Tcl("update idletasks")
        tkwm.resizable(window, 0, 0)
        if (bindReturn) tkbind(window, "<Return>", onOK)
        if (.double.click) tkbind(window, "<Double-ButtonPress-1>", onOK)
        tkwm.deiconify(window)
        # focus grabs appear to cause problems for some dialogs
        if (.grab.focus && (!preventGrabFocus)) tkgrab.set(window)
        tkfocus(focus)
        tkwait.window(window)
        }
    )

            
variableListBox <- function(parentWindow, variableList=.variables, bg="white",
    selectmode="single", export="FALSE", initialSelection=NULL, listHeight=4, title){
    if (selectmode == "multiple") selectmode <- .multiple.select.mode
    frame <- tkframe(parentWindow)
    listbox <- tklistbox(frame, height=min(listHeight, length(variableList)),
        selectmode=selectmode, background=bg, exportselection=export)
    scrollbar <- tkscrollbar(frame, repeatinterval=5, command=function(...) tkyview(listbox, ...))
    tkconfigure(listbox, yscrollcommand=function(...) tkset(scrollbar, ...))
    for (var in variableList) tkinsert(listbox, "end", var)
    if (!is.null(initialSelection)) tkselection.set(listbox, initialSelection)  
    tkgrid(tklabel(frame, text=title, fg="blue"), columnspan=2, sticky="w")
    tkgrid(listbox, scrollbar, sticky="nw")
    tkgrid.configure(scrollbar, sticky="wns")
    tkgrid.configure(listbox, sticky="ew")
    result <- list(frame=frame, listbox=listbox, scrollbar=scrollbar, 
        selectmode=selectmode, varlist=variableList)
    class(result) <- "listbox"
    result
    }      
            
getSelection <- function(object) UseMethod("getSelection")

getSelection.listbox <- function(object){
    object$varlist[as.numeric(tkcurselection(object$listbox)) + 1]
    }
    
getFrame <- function(object) UseMethod("getFrame")

getFrame.listbox <- function(object){
    object$frame
    }

radioButtons <- defmacro(window=top, name, buttons, values=NULL, initialValue=..values[1], labels, title,
    expr={
        ..values <- if (is.null(values)) buttons else values
        ..frame <- paste(name, "Frame", sep="")
        assign(..frame, tkframe(window))
        ..variable <- paste(name, "Variable", sep="")
        assign(..variable, tclVar(initialValue))
        tkgrid(tklabel(eval(parse(text=..frame)), text=title, fg="blue"), columnspan=2, sticky="w")
        for (i in 1:length(buttons)) {
            ..button <- paste(buttons[i], "Button", sep="")
            assign(..button, 
                tkradiobutton(eval(parse(text=..frame)), variable=eval(parse(text=..variable)), value=..values[i]))
            tkgrid(tklabel(eval(parse(text=..frame)), text=labels[i], justify="left"), eval(parse(text=..button)), sticky="w")
            }
        }
    )
            
                    
checkBoxes <- defmacro(window=top, frame, boxes, initialValues=NULL, labels,
    expr={
        ..initialValues <- if (is.null(initialValues)) rep("1", length(boxes)) else initialValues
        assign(frame, tkframe(window))
        ..variables <- paste(boxes, "Variable", sep="")
        for (i in 1:length(boxes)) {
            assign(..variables[i], tclVar(..initialValues[i]))
            ..checkBox <- paste(boxes[i], "CheckBox", sep="")
            assign(..checkBox, 
                tkcheckbutton(eval(parse(text=frame)), variable=eval(parse(text=..variables[i]))))
            tkgrid(tklabel(eval(parse(text=frame)), text=labels[i]), eval(parse(text=..checkBox)), sticky="w")
            }
        }
    )

checkReplace <- function(name, type="Variable"){
    tkmessageBox(message=paste(type, " ", name, " already exists.\nOverwrite ", 
        tolower(type),"?", sep=""), icon="warning", type="yesno", default="no")
    }

errorCondition <- defmacro(window=top, recall=NULL, message, model=FALSE,
    expr={
        if (model) assign(".modelNumber", .modelNumber - 1, envir=.GlobalEnv) 
        if (.grab.focus) tkgrab.release(window)
        tkdestroy(window)
        tkmessageBox(message=message,
            icon="error", type="ok", default="ok")
        if (!is.null(recall)) recall()
        })

subsetBox <- defmacro(window=top, model=FALSE, 
    expr={
            subsetVariable <- if (model){
                if (currentModel && currentFields$subset != "") 
                    tclVar(currentFields$subset) else tclVar("<all valid cases>")
                }
            else tclVar("<all valid cases>")
            subsetFrame <- tkframe(window)
            subsetEntry <- tkentry(subsetFrame, width="20", textvariable=subsetVariable)
            subsetScroll <- tkscrollbar(subsetFrame, orient="horizontal",
                repeatinterval=5, command=function(...) tkxview(subsetEntry, ...))
            tkconfigure(subsetEntry, xscrollcommand=function(...) tkset(subsetScroll, ...))
            tkgrid(tklabel(subsetFrame, text="Subset expression", fg="blue"), sticky="w")
            tkgrid(subsetEntry, sticky="w")
            tkgrid(subsetScroll, sticky="ew")
            })

groupsBox <- defmacro(recall=NULL, label="Plot by:", initialLabel="Plot by groups",
    plotLinesByGroup=FALSE, positionLegend=FALSE, plotLinesByGroupsText="Plot lines by group",
    expr={
        env <- environment()
        .groups <- FALSE
        .linesByGroup <- FALSE
        .groupsLabel <- tclVar(paste(initialLabel, "...", sep=""))
        onGroups <- function(){
            if (length(.factors) == 0){
                errorCondition(recall=recall, message="There no factors in the active data set.") 
                return()
                }
            initializeDialog(subdialog, title="Groups")
            groupsBox <- variableListBox(subdialog, .factors, title="Groups variable (pick one)")
            if (plotLinesByGroup){
                linesByGroupFrame <- tkframe(subdialog)
                linesByGroup <- tclVar("1")
                linesCheckBox <- tkcheckbutton(linesByGroupFrame, variable=linesByGroup)
                tkgrid(tklabel(linesByGroupFrame, text=plotLinesByGroupsText), linesCheckBox, sticky="w")
                }
            onOKsub <- function() {
                groups <- getSelection(groupsBox)
                if (length(groups) == 0){
                    assign(".groups", FALSE, envir=env)
                    tclvalue(.groupsLabel) <- paste(initialLabel, "...", sep="")
                    tkconfigure(groupsButton, fg="black")
                    if (.grab.focus) tkgrab.release(subdialog)
                    tkdestroy(subdialog)
                    tkwm.deiconify(top)
                    if (.grab.focus) tkgrab.set(top)
                    tkfocus(top)
                    tkwait.window(top)                
                    return()
                    }
                assign(".groups", groups, envir=env)
                tclvalue(.groupsLabel) <- paste(label, groups)
                tkconfigure(groupsButton, fg="blue")
                if (plotLinesByGroup) {
                    lines <- as.character("1" == tclvalue(linesByGroup))
                    assign(".linesByGroup", lines, envir=env)
                    }
                if (.grab.focus) tkgrab.release(subdialog)
                tkdestroy(subdialog)
                tkwm.deiconify(top)
                if (.grab.focus) tkgrab.set(top)
                tkfocus(top)
                tkwait.window(top)
                }
            subOKCancelHelp()
            tkgrid(getFrame(groupsBox), sticky="nw")
            if (plotLinesByGroup) tkgrid(linesByGroupFrame, sticky="w")
            tkgrid(subButtonsFrame, sticky="w")
            if (positionLegend) tkgrid(tklabel(subdialog, text="Position legend with mouse click", fg="blue"))
            dialogSuffix(subdialog, onOK=onOKsub, rows=3+plotLinesByGroup+positionLegend, columns=2, focus=subdialog)
            }
        groupsFrame <- tkframe(top)
        groupsButton <- tkbutton(groupsFrame, textvariable=.groupsLabel, command=onGroups, borderwidth=3)
        tkgrid(tklabel(groupsFrame, text="    "), groupsButton, sticky="w")
        })

groupsLabel <- defmacro(frame=top, groupsBox=groupsBox, columnspan=1,
    expr={
        groupsFrame <- tkframe(frame)
        groupsLabel <- tklabel(groupsFrame, text="<No groups selected>")    
        tkgrid(tklabel(groupsFrame, text="Difference: ", fg="blue"), groupsLabel, sticky="w")
        tkgrid(groupsFrame, sticky="w", columnspan=columnspan)
        onSelect <- function(){
            group <- getSelection(groupsBox)
            levels <- eval(parse(text=paste("levels(", .activeDataSet, "$", group, ")", sep="")))
            tkconfigure(groupsLabel, text=paste(levels[1], "-", levels[2]))
            }
        tkbind(groupsBox$listbox, "<ButtonRelease-1>", onSelect)
        })

modelFormula <- defmacro(frame=top, hasLhs=TRUE, expr={
    checkAddOperator <- function(rhs){
        rhs.chars <- rev(strsplit(rhs, "")[[1]])
        if (length(rhs.chars) < 1) return(FALSE)
        check.char <- if ((rhs.chars[1] != " ") || (length(rhs.chars) == 1)) 
                rhs.chars[1] else rhs.chars[2]
        !is.element(check.char, c("+", "*", ":", "/", "-", "^", "(", "%"))
        }
    variables <- paste(.variables, ifelse(is.element(.variables, .factors), "[factor]", ""))
    xBox <- variableListBox(frame, variables, title="Variables (double-click to formula)")
    onDoubleClick <- if (!hasLhs){
        function(){
            var <- getSelection(xBox)
            if (length(grep("\\[factor\\]", var)) == 1) var <- sub("\\[factor\\]", "",  var)
            tkfocus(rhsEntry)
            rhs <- tclvalue(rhsVariable)
            rhs.chars <- rev(strsplit(rhs, "")[[1]])
            check.char <- if (length(rhs.chars) > 0){
                if ((rhs.chars[1] != " ") || (length(rhs.chars) == 1)) 
                    rhs.chars[1] else rhs.chars[2]
                }
                else ""
            tclvalue(rhsVariable) <- if (rhs == "" || 
                is.element(check.char, c("+", "*", ":", "/", "-", "^", "(", "%")))
                    paste(rhs, var, sep="")
                else paste(rhs, "+", var)
            tkicursor(rhsEntry, "end")
            tkxview.moveto(rhsEntry, "1")
            }
        }
    else{
        function(){
            var <- getSelection(xBox)
            if (length(grep("\\[factor\\]", var)) == 1) var <- sub("\\[factor\\]", "",  var)
            lhs <- tclvalue(lhsVariable)
            if (lhs == "") tclvalue(lhsVariable) <- var
            else {
                tkfocus(rhsEntry)
                rhs <- tclvalue(rhsVariable)
                rhs.chars <- rev(strsplit(rhs, "")[[1]])
                check.char <- if (length(rhs.chars) > 0){
                    if ((rhs.chars[1] != " ") || (length(rhs.chars) == 1)) 
                        rhs.chars[1] else rhs.chars[2]
                    }
                    else ""
                tclvalue(rhsVariable) <- if (rhs == "" || 
                    is.element(check.char, c("+", "*", ":", "/", "-", "^", "(", "%")))
                        paste(rhs, var, sep="")
                    else paste(rhs, "+", var)
                }
            tkicursor(rhsEntry, "end")
            tkxview.moveto(rhsEntry, "1")
            }
        }
    tkbind(xBox$listbox, "<Double-ButtonPress-1>", onDoubleClick)
    onPlus <- function(){
        rhs <- tclvalue(rhsVariable)
        if (!checkAddOperator(rhs)) return()
        tclvalue(rhsVariable) <- paste(rhs, "+ ")
        tkicursor(rhsEntry, "end")
        tkxview.moveto(rhsEntry, "1")
        }
    onTimes <- function(){
        rhs <- tclvalue(rhsVariable)
        if (!checkAddOperator(rhs)) return()
        tclvalue(rhsVariable) <- paste(rhs, "*", sep="")
        tkicursor(rhsEntry, "end")
        tkxview.moveto(rhsEntry, "1")
        }
    onColon <- function(){
        rhs <- tclvalue(rhsVariable)
        if (!checkAddOperator(rhs)) return()
        tclvalue(rhsVariable) <- paste(rhs, ":", sep="")
        tkicursor(rhsEntry, "end")
        tkxview.moveto(rhsEntry, "1")
        }
    onSlash <- function(){
        rhs <- tclvalue(rhsVariable)
        if (!checkAddOperator(rhs)) return()
        tclvalue(rhsVariable) <- paste(rhs, "/",  sep="")
        tkicursor(rhsEntry, "end")
        tkxview.moveto(rhsEntry, "1")
        }
    onIn <- function(){
        rhs <- tclvalue(rhsVariable)
        if (!checkAddOperator(rhs)) return()
        tclvalue(rhsVariable) <- paste(rhs, "%in% ")
        tkicursor(rhsEntry, "end")
        tkxview.moveto(rhsEntry, "1")
        }
    onMinus <- function(){
        rhs <- tclvalue(rhsVariable)
        if (!checkAddOperator(rhs)) return()
        tclvalue(rhsVariable) <- paste(rhs, "- ")
        tkicursor(rhsEntry, "end")
        tkxview.moveto(rhsEntry, "1")
        }
    onPower <- function(){
        rhs <- tclvalue(rhsVariable)
        if (!checkAddOperator(rhs)) return()
        tclvalue(rhsVariable) <- paste(rhs, "^", sep="")
        tkicursor(rhsEntry, "end")
        tkxview.moveto(rhsEntry, "1")
        }
    onLeftParen <- function(){
        tkfocus(rhsEntry)
        rhs <- tclvalue(rhsVariable)
        tclvalue(rhsVariable) <- paste(rhs, "(", sep="")
        tkicursor(rhsEntry, "end")
        tkxview.moveto(rhsEntry, "1")
        }
    onRightParen <- function(){
        rhs <- tclvalue(rhsVariable)
        if (!checkAddOperator(rhs)) return()
        tclvalue(rhsVariable) <- paste(rhs, ")", sep="")
        tkicursor(rhsEntry, "end")
        tkxview.moveto(rhsEntry, "1")
        }
    outerOperatorsFrame <- tkframe(frame)
    operatorsFrame <- tkframe(outerOperatorsFrame)
    plusButton <- tkbutton(operatorsFrame, text="+", width="3", command=onPlus, 
        font=.operatorFont)
    timesButton <- tkbutton(operatorsFrame, text="*", width="3", command=onTimes, 
        font=.operatorFont)
    colonButton <- tkbutton(operatorsFrame, text=":", width="3", command=onColon, 
        font=.operatorFont)
    slashButton <- tkbutton(operatorsFrame, text="/", width="3", command=onSlash, 
        font=.operatorFont)
    inButton <- tkbutton(operatorsFrame, text="%in%", width="3", command=onIn,
        font=.operatorFont)
    minusButton <- tkbutton(operatorsFrame, text="-", width="3", command=onMinus, 
        font=.operatorFont)
    powerButton <- tkbutton(operatorsFrame, text="^", width="3", command=onPower, 
        font=.operatorFont)
    leftParenButton <- tkbutton(operatorsFrame, text="(", width="3", command=onLeftParen, 
        font=.operatorFont)
    rightParenButton <- tkbutton(operatorsFrame, text=")", width="3", command=onRightParen, 
        font=.operatorFont)
    tkgrid(plusButton, timesButton, colonButton, slashButton, inButton, minusButton,
        powerButton, leftParenButton, rightParenButton, sticky="w")
    formulaFrame <- tkframe(frame)
    if (hasLhs){
        tkgrid(tklabel(outerOperatorsFrame, text="Model Formula:     ", fg="blue"), operatorsFrame)
        lhsVariable <- if (currentModel) tclVar(currentFields$lhs) else tclVar("")
        rhsVariable <- if (currentModel) tclVar(currentFields$rhs) else tclVar("")
        rhsEntry <- tkentry(formulaFrame, width="50", textvariable=rhsVariable)
        rhsXscroll <- tkscrollbar(formulaFrame, repeatinterval=10,
            orient="horizontal", command=function(...) tkxview(rhs, ...))
        tkconfigure(rhsEntry, xscrollcommand=function(...) tkset(rhsXscroll, ...))          
        lhsEntry <- tkentry(formulaFrame, width="10", textvariable=lhsVariable)
        lhsScroll <- tkscrollbar(formulaFrame, repeatinterval=5, 
            orient="horizontal", command=function(...) tkxview(lhsEntry, ...))
        tkconfigure(lhsEntry, xscrollcommand=function(...) tkset(lhsScroll, ...))
        tkgrid(lhsEntry, tklabel(formulaFrame, text=" ~    "), rhsEntry, sticky="w")
        tkgrid(lhsScroll, tklabel(formulaFrame, text=""), rhsXscroll, sticky="w")
        tkgrid.configure(lhsScroll, sticky="ew")
        }
    else{
        rhsVariable <- tclVar("")
        rhsEntry <- tkentry(formulaFrame, width="50", textvariable=rhsVariable)
        rhsXscroll <- tkscrollbar(formulaFrame, repeatinterval=10,
            orient="horizontal", command=function(...) tkxview(rhs, ...))
        tkconfigure(rhsEntry, xscrollcommand=function(...) tkset(rhsXscroll, ...))  
        tkgrid(tklabel(formulaFrame, text="   ~ "), rhsEntry, sticky="w")
        tkgrid(tklabel(formulaFrame, text=""), rhsXscroll, sticky="w")
        }
    tkgrid.configure(rhsXscroll, sticky="ew")
    })

exists.method <- function(generic, object, default=TRUE, strict=FALSE){
    classes <- class(object)
    if (default) classes <- c(classes, "default")
    if (strict) classes <- classes[1]
    any(paste(generic, ".", classes, sep="") %in%
        as.character(methods(generic)))
    }

checkMethod <- defmacro(generic, object, message=NULL, default=FALSE, strict=FALSE,
    expr={
        msg <- if (is.null(message)) paste("No appropriate", generic, "method exists\nfor a model of this class.")
            else message
        method <- exists.method(generic, eval(parse(text=object)), default=default, strict=strict)
        if (!method) tkmessageBox(message=msg, icon="error", type="ok", default="ok")
        method
        }
    )
    
checkClass <- defmacro(object, class, message=NULL,
    expr={
        msg <- if (is.null(message)) paste('The model is not of class "', class, '".')
            else message
       properClass <- eval(parse(text=paste("class(", object, ")")))[1] == class
       if (!properClass) tkmessageBox(message=msg, icon="error", type="ok", default="ok")
       properClass
       }
    )
    

# the following function is from John Chambers

isS4object <- function(object) {
     if(length(attr(object, "class"))!= 1)
         return(FALSE)
    !isVirtualClass(getClass(class(object), TRUE)) }


#isS4object <- function(object) {
#    !(length(object) == 1 && class(object) == "character") &&  length(slotNames(object)) != 0
#    }
