R/utilities.R

Defines functions anova.glmerMod coef.lmerMod linearHypothesis.lmerMod Anova.lmerMod anova.lmerMod removeRedundantExtension modelCapability levels.character browsePDF RcmdrCapabilities hasProgram appnap mavericksP RappP editDataset.data.frame editDataset.NULL editDataset.character editDataset setIdleCursor setBusyCursor is.SciViews RcmdrEditor knitrP compileRnw removeLastRnwBlock trimHangingEndRnwBlock enterKnitr removeStrayRnwBlocks removeNullRnwBlocks endRnwBlock beginRnwBlock compileRmd MarkdownP cutstring removeLastRmdSection removeLastRmdBlock trimHangingEndRmdBlock enterMarkdown findCommandName cleanUpArg removeStrayRmdBlocks removeNullRmdBlocks endRmdBlock beginRmdBlock suppressMarkdown trimTrailingNewLines knitrEditorWindow MarkdownEditorWindow RStudioP X11P WindowsP tkspinbox tkfocus gassign flushDialogMemory varPosn getDialog startHelp Library sortVarNames splitCmd tclvalue titleLabel is.model whitespaceonly loadPlugins listPlugins insertRows packagesAvailable trim.col.na RcmdrTkmessageBox English gettextMenus gettextRcmdr activateMenus rglLoaded packageAvailable MacOSXP hclustSolutionsP multinomP polrP EffectP anovaP logLikP glmP lmP activeModelP modelsP twoLevelFactorsP characterP factorsP numericP dataSetsP activeDataSetP MessagesWindow OutputWindow RnwWindow RmdWindow LogWindow CommanderWindow UpdateModelNumber GrabFocus ActiveModel ActiveDataSet TwoLevelFactors Factors Character Numeric Variables RcmdrTclSet getRcmdr putRcmdr RcmdrEnv isS4object exists.method checkReplace getFrame.combobox getSelection.combobox variableComboBox getFrame.listbox gettextRmdHeader applyDefaultValues insertRmdSection getCases getUserName CoefficientsP Coefficients PredictorsP Predictors convertStrings2Factors discreteNumericP DiscreteNumeric listDiscreteNumeric validColumns plot.glmerMod plot.lmerMod coef.glmerMod linearHypothesis.glmerMod Anova.glmerMod getFrame getSelection.listbox getSelection variableListBox checkVariables checkNumeric checkTwoLevelFactors checkFactors checkActiveModel checkActiveDataSet defmacro browseRcmdrHexSticker browseRMarkdown browseRWebsite browseRcmdrWebsite manualTranslationP browseEnglishManual browseManual helpAboutCommander helpCommander Coef.merMod Coef.default Coef is.valid.number is.valid.name trim.blanks listCharacter listNumeric listTwoLevelFactors listFactors listVariables activeModel activeDataSet listAllModels listGLMMs listLMMs listProportionalOddsModels listMultinomialLogitModels listGeneralizedLinearModels listAOVModels listLinearModels listDataSets

Documented in activateMenus activeDataSet ActiveDataSet activeDataSetP activeModel ActiveModel activeModelP anovaP beginRmdBlock beginRnwBlock Character characterP checkActiveDataSet checkActiveModel checkFactors checkNumeric checkReplace checkTwoLevelFactors checkVariables Coef Coefficients CoefficientsP CommanderWindow dataSetsP defmacro DiscreteNumeric discreteNumericP editDataset editDataset.character editDataset.data.frame editDataset.NULL EffectP endRmdBlock endRnwBlock enterKnitr enterMarkdown exists.method Factors factorsP flushDialogMemory gassign getCases getDialog getFrame getFrame.combobox getFrame.listbox getRcmdr getSelection getSelection.combobox getSelection.listbox gettextRcmdr glmP GrabFocus hclustSolutionsP insertRmdSection is.SciViews is.valid.name is.valid.number knitrP Library listAllModels listAOVModels listCharacter listDataSets listDiscreteNumeric listFactors listGeneralizedLinearModels listLinearModels listMultinomialLogitModels listNumeric listPlugins listProportionalOddsModels listTwoLevelFactors listVariables lmP logLikP LogWindow MacOSXP manualTranslationP MarkdownP mavericksP MessagesWindow modelCapability modelsP multinomP Numeric numericP OutputWindow packageAvailable polrP Predictors PredictorsP putRcmdr RappP RcmdrEditor RcmdrTclSet RcmdrTkmessageBox removeLastRmdBlock removeLastRnwBlock removeNullRmdBlocks removeNullRnwBlocks removeStrayRmdBlocks removeStrayRnwBlocks rglLoaded RmdWindow RnwWindow setBusyCursor setIdleCursor sortVarNames suppressMarkdown tclvalue titleLabel tkfocus tkspinbox trim.blanks TwoLevelFactors twoLevelFactorsP UpdateModelNumber variableComboBox variableListBox Variables varPosn WindowsP X11P

# last modified 2023-08-07 by J. Fox

# utility functions

# listing objects etc.

listDataSets <- function(envir=.GlobalEnv, ...) {
    Vars <- ls(envir = envir, all.names = TRUE) # + PhG
    if (length(Vars) == 0) return(Vars) # + PhG
    
    names(which(sapply(Vars, function(.x) is.data.frame(get(.x, envir=envir)))))
}

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

listAOVModels <- function(envir=.GlobalEnv, ...) {
    objects <- ls(envir=envir, ...)
    if (length(objects) == 0) NULL
    else objects[sapply(objects,
        function(.x) "aov" == (class(get(.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(get(.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(get(.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(get(.x, envir=envir))[1]))]
}

listLMMs <- function(envir=.GlobalEnv, ...) {
  objects <- ls(envir=envir, ...)
  if (length(objects) == 0) NULL
  else objects[sapply(objects,
                      function(.x) "lmerMod" == (class(get(.x, envir=envir))[1]))]
}

listGLMMs <- function(envir=.GlobalEnv, ...) {
  objects <- ls(envir=envir, ...)
  if (length(objects) == 0) NULL
  else objects[sapply(objects,
                      function(.x) "glmerMod" == (class(get(.x, envir=envir))[1]))]
}

listAllModels <- function(envir=.GlobalEnv, ...) {
    objects <- ls(envir=envir, ...)
    if (length(objects) == 0) NULL
    else objects[sapply(objects,
        function(.x) (class(get(.x, envir=envir))[1])) %in% getRcmdr("modelClasses")]
}

activeDataSet <- function(dsname, flushModel=TRUE, flushDialogMemory=TRUE){
    .activeDataSet <- ActiveDataSet()
    if (missing(dsname)) {
        if (is.null(.activeDataSet)){
            Message(message=gettextRcmdr("There is no active data set."), type="error")
            return(FALSE)
        }
        else return(.activeDataSet)
    }
    if (!is.data.frame(ds <- get(dsname, envir=.GlobalEnv))){
        if (!exists.method("as.data.frame", ds, default=FALSE)){
            Message(message=paste(dsname, gettextRcmdr(" is not a data frame and cannot be attached."),
                sep=""), type="error")
            tkfocus(CommanderWindow())
            return()
        }
        command <- paste(dsname, " <- as.data.frame(", dsname, ")", sep="")
        justDoIt(command)
        logger(command)
        Message(message=paste(dsname, gettextRcmdr(" has been coerced to a data frame"), sep=""),
            type="warning")
    }
    valid.columns <- validColumns(get(dsname, envir=.GlobalEnv))
    if (any(!valid.columns)) {
      command <- paste0(dsname, " <- ", dsname, "[, c(", paste(valid.columns, collapse=","), ")]")
      doItAndPrint(command)
    }
    varnames <- names(get(dsname, envir=.GlobalEnv))
    newnames <- make.names(varnames)
    badnames <- varnames != newnames
    if (any(badnames)){
        command <- paste("names(", dsname, ") <- make.names(names(",
            dsname, "))", sep="")
        doItAndPrint(command)
    }
    if (!is.null(.activeDataSet) && getRcmdr("attach.data.set")
        && (length(grep(.activeDataSet, search())) !=0)) {
        detach(pos = match(.activeDataSet, search()))
        logger(paste("detach(", .activeDataSet, ")", sep=""))
    }
    if (flushModel) {
        putRcmdr(".activeModel", NULL)
        RcmdrTclSet("modelName", gettextRcmdr("<No active model>"))
        tkconfigure(getRcmdr("modelLabel"), foreground="red")
    }
    if (flushDialogMemory) putRcmdr("dialog.values", list())
    ActiveDataSet(dsname)
    nrow <- nrow(get(dsname, envir=.GlobalEnv))
    ncol <- ncol(get(dsname, envir=.GlobalEnv))
    putRcmdr("nrow", nrow)
    putRcmdr("ncol", ncol)
    Message(sprintf(gettextRcmdr("The dataset %s has %d rows and %d columns."), dsname,
        nrow, ncol), type="note")
    if (any(badnames)) Message(message=paste(dsname, gettextRcmdr(" contains non-standard variable names:\n"),
        paste(varnames[badnames], collapse=", "),
        gettextRcmdr("\nThese have been changed to:\n"), paste(newnames[badnames], collapse=", "),
        sep=""), type="warning")
    RcmdrTclSet("dataSetName", paste(" ", dsname, " "))
    tkconfigure(getRcmdr("dataSetLabel"), foreground="blue")
    activateMenus()
    dsname
}


activeModel <- function(model){
    if (missing(model)) {
        .activeModel <- ActiveModel()
        if (is.null(.activeModel)){
            Message(message=gettextRcmdr("There is no active model."), type="error")
            return(FALSE)
        }
        else return(.activeModel)
    }
    ActiveModel(model)
    RcmdrTclSet("modelName", paste(" ", model, " "))
    tkconfigure(getRcmdr("modelLabel"), foreground="blue")
    activateMenus()
    model
}

listVariables <- function(dataSet=ActiveDataSet()) {
    if(missing(dataSet)) {
        Variables()
    }
    else {
        vars <- names(get(dataSet, envir=.GlobalEnv))
        if (getRcmdr("sort.names")) sortVarNames(vars) else vars
    }
}

listFactors <- function(dataSet=ActiveDataSet()) {
  if(missing(dataSet)) {
    Factors()
  }
  else {
    variables <- listVariables(dataSet)
    variables[sapply(variables, function(.x){
      .v <- eval(parse(text=.x), envir=get(dataSet, envir=.GlobalEnv))
      is.factor(.v) || is.logical(.v) || is.character(.v)
    })]
  }
}

listTwoLevelFactors <- function(dataSet=ActiveDataSet()){
  if(missing(dataSet)) {
    TwoLevelFactors()
  }
  else {
    factors <- listFactors(dataSet)
    if(length(factors) == 0) return(NULL)
    factors[sapply(factors, function(.x){
      .v <- eval(parse(text=.x), envir=get(dataSet, envir=.GlobalEnv))
      2 == length(levels(.v)) || length(na.omit(unique(.v))) == 2
    })]
  }
}

listNumeric <- function(dataSet=ActiveDataSet()) {
    if(missing(dataSet)) {
        Numeric()
    }
    else {
        variables <- listVariables(dataSet)
        variables[sapply(variables,function(.x)
            is.numeric(eval(parse(text=.x), envir=get(dataSet, envir=.GlobalEnv))))]
    }
}

listCharacter <- function(dataSet=ActiveDataSet()) {
  if(missing(dataSet)) {
    Character()
  }
  else {
    variables <- listVariables(dataSet)
    variables[sapply(variables,function(.x)
      is.character(eval(parse(text=.x), envir=get(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)
}

is.valid.number <- function(string){
    warn <- options(warn=-1)
    on.exit(warn)
    number <- as.numeric(string)
    if (any(is.na(number))) FALSE else TRUE
}

# statistical

Coef <- function(object, ...) UseMethod("Coef")

Coef.default <- function(object, ...) coef(object, ...)

Coef.multinom <- function (object, ...) {
    # the following adapted from nnet:
    cf <- function (object, ...) 
    {
        r <- length(object$vcoefnames)
        if (length(object$lev) == 2L) {
            coef <- object$wts[1L + (1L:r)]
            names(coef) <- object$vcoefnames
        }
        else {
            coef <- matrix(object$wts, nrow = object$n[3L], byrow = TRUE)[, 
                                                                          1L + (1L:r), drop = FALSE]
            if (length(object$lev)) 
                dimnames(coef) <- list(object$lev, object$vcoefnames)
            if (length(object$lab)) 
                dimnames(coef) <- list(object$lab, object$vcoefnames)
            coef <- coef[-1L, , drop = FALSE]
        }
        coef
    }
    b <- cf(object, ...)
    cn <- colnames(b)
    rn <- rownames(b)
    b <- as.vector(t(b))
    names(b) <- as.vector(outer(cn, rn, function(c, r) paste(r, c, sep = ":")))
    b
}

Coef.merMod <- function(object, ...) fixef(object, ...)


# Pager

# this is slightly modified from tkpager to use the Rcmdr monospaced font
#   and a white background

RcmdrPager <- function (file, header, title, delete.file)
{
    title <- paste(title, header)
    for (i in seq(along = file)) {
        zfile <- file[[i]]
        tt <- tktoplevel()
        if (WindowsP()) tkwm.iconbitmap(tt, system.file("etc", "R-logo.ico", package="Rcmdr"))
        tkwm.title(tt, if (length(title))
            title[(i - 1)%%length(title) + 1]
            else "")
        txt <- tktext(tt, bg = "white", font = getRcmdr("logFont"))
        scr <- ttkscrollbar(tt, 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 <- tcl("open", zfile)
        tkinsert(txt, "end", gsub("_\b", "", tclvalue(tcl("read",
            chn))))
        tcl("close", chn)
        tkconfigure(txt, state = "disabled")
        tkmark.set(txt, "insert", "0.0")
        tkfocus(txt)
        if (delete.file)
            tcl("file", "delete", zfile)
    }
}

# help functions

helpCommander <- function() {
    PDF <- file.access(paste(file.path(path.package(package="Rcmdr")[1], "doc"), 
        "/", gettextRcmdr("Commander"), ".pdf", sep=""), mode=4)
    if (PDF == 0){
        browseURL(paste(file.path(path.package(package="Rcmdr")[1], "doc"),
            "/", gettextRcmdr("Commander"), ".pdf", sep=""))
    } 
    else if (as.numeric(R.Version()$major) >= 2) print(help(gettextRcmdr("Commander")))
    else help(gettextRcmdr("Commander"))
}

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

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

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

manualTranslationP <- function(){
    gettextRcmdr("Getting-Started-with-the-Rcmdr") != "Getting-Started-with-the-Rcmdr"
}

browseRcmdrWebsite <- function() browseURL("https://socialsciences.mcmaster.ca/jfox/Misc/Rcmdr/")

browseRWebsite <- function() browseURL("https://www.r-project.org/")

browseRMarkdown <- function() browseURL("https://rmarkdown.rstudio.com/lesson-1.html")

browseRcmdrHexSticker <- function(){
  browseURL(paste0("file://", system.file("etc", "Rcmdr-hex.pdf", package="Rcmdr")))
}

# functions for building dialog boxes

# the following function is slightly modified, with permission, 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.out=length(a))){
        if (nn[i] == "") {
            nn[i] <- paste(a[[i]])
            msg <- paste(a[[i]], gettext("not supplied", domain="R-Rcmdr"))
            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, reset=NULL, apply=NULL, helpPackage=NULL,
    expr={
        memory <- getRcmdr("retain.selections")
        button.strings <- c("OK", "Cancel", 
                            if (!is.null(helpSubject)) "Help", 
                            if (!is.null(reset) && memory) "Reset", 
                            if (!is.null(apply)) "Apply")
        width <- max(nchar(gettextRcmdr(button.strings)))
        if (WindowsP()) width <- width + 2
        buttonsFrame <- tkframe(window)
        leftButtonsBox <- tkframe(buttonsFrame)
        rightButtonsBox <- tkframe(buttonsFrame)
        
        OnOK <- function(){
            putRcmdr("restoreTab", FALSE)
            if (getRcmdr("use.markdown")) {
                putRcmdr("startNewCommandBlock", FALSE)
                beginRmdBlock()
            }
            if (getRcmdr("use.knitr")) {
                putRcmdr("startNewKnitrCommandBlock", FALSE)
                beginRnwBlock()
            }
            setBusyCursor()
            on.exit(setIdleCursor())
            onOK()
            if (model) putDialog ("effectPlots", NULL)
            if (getRcmdr("use.markdown")){
                removeNullRmdBlocks()
                putRcmdr("startNewCommandBlock", TRUE)
                if (getRcmdr("rmd.generated")) {
                    endRmdBlock()
                    putRcmdr("rmd.generated", FALSE)
                }
                removeNullRmdBlocks()
            }
            if (getRcmdr("use.knitr")){
                removeNullRnwBlocks()
                putRcmdr("startNewKnitrCommandBlock", TRUE)
                if (getRcmdr("rnw.generated")) {
                    endRnwBlock()
                    putRcmdr("rnw.generated", FALSE)
                }
                removeNullRnwBlocks()
            }
            putRcmdr("rgl.command", FALSE)
        }
        
        OKbutton <- buttonRcmdr(rightButtonsBox, text=gettextRcmdr("OK"), foreground="darkgreen", width=width, command=OnOK, default="active",
            image="::image::okIcon", compound="left")
        
        onCancel <- function() {
            if (exists(".exit")){
                result <- .exit()
                if (result == "abort") return()
            }
            putRcmdr("restoreTab", FALSE)
            if (model) putRcmdr("modelNumber", getRcmdr("modelNumber") - 1)
            if (GrabFocus()) tkgrab.release(window)
            tkdestroy(window)
            putRcmdr("rgl.command", FALSE)
            tkfocus(CommanderWindow())
        }
        
        cancelButton <- buttonRcmdr(rightButtonsBox, text=gettextRcmdr("Cancel"), foreground="red", width=width, command=onCancel, # borderwidth=3,
            image="::image::cancelIcon", compound="left")
        
        if (!is.null(helpSubject)){
            onHelp <- function() {
                if (GrabFocus() && (!WindowsP())) tkgrab.release(window)
                if (as.numeric(R.Version()$major) >= 2) print(help(helpSubject, package=helpPackage))
                else help(helpSubject, package=helpPackage)
            }
            helpButton <- buttonRcmdr(leftButtonsBox, text=gettextRcmdr("Help"), width=width, command=onHelp, # borderwidth=3,
                image="::image::helpIcon", compound="left")
        }
        
        if (!is.null(reset) && memory){
            onReset <- function(){
                ID <- window$ID
                putRcmdr("cancelDialogReopen", TRUE)
                putRcmdr("open.dialog.here", as.character(.Tcl(paste("winfo geometry", ID))))
                if (model) putRcmdr("modelNumber", getRcmdr("modelNumber") - 1)
                putDialog(reset, NULL)
                putDialog(reset, NULL, resettable=FALSE)
                closeDialog()
                eval(parse(text=paste(reset, "()")))
                putRcmdr("open.dialog.here", NULL)
                putRcmdr("restoreTab", FALSE)
            }
            resetButton <- buttonRcmdr(leftButtonsBox, text=gettextRcmdr("Reset"), width=width, command=onReset,
                image="::image::resetIcon", compound="left")
        }
        
        if (!is.null(apply)){
            onApply <- function(){
                putRcmdr("restoreTab", TRUE)
                putRcmdr("cancelDialogReopen", FALSE)
                putRcmdr("onApplyCalled", TRUE)
                ID <- window$ID
                putRcmdr("open.dialog.here", as.character(.Tcl(paste("winfo geometry", ID))))
                if (getRcmdr("use.markdown")) {
                    putRcmdr("startNewCommandBlock", FALSE)
                    beginRmdBlock()
                }
                if (getRcmdr("use.knitr")) {
                    putRcmdr("startNewKnitrCommandBlock", FALSE)
                    beginRnwBlock()
                }
                setBusyCursor()
                on.exit(setIdleCursor())
                onOK()
                putRcmdr("rgl.command", FALSE)
                if (getRcmdr("use.markdown")){
                    removeNullRmdBlocks()
                    putRcmdr("startNewCommandBlock", TRUE)
                    if (getRcmdr("rmd.generated")) {
                        endRmdBlock()
                        putRcmdr("rmd.generated", FALSE)
                    }
                    removeNullRmdBlocks()
                }
                if (getRcmdr("use.knitr")){
                    removeNullRnwBlocks()
                    putRcmdr("startNewKnitrCommandBlock", TRUE)
                    if (getRcmdr("rnw.generated")) {
                        endRnwBlock()
                        putRcmdr("rnw.generated", FALSE)
                    }
                    removeNullRnwBlocks()
                }
                if (getRcmdr("cancelDialogReopen")){
                    putRcmdr("cancelDialogReopen", FALSE)
                }
                else{
                    eval(parse(text=paste(apply, "()")))
                    putRcmdr("open.dialog.here", NULL)
                }
            }
            applyButton <- buttonRcmdr(rightButtonsBox, text=gettextRcmdr("Apply"), foreground="yellow", width=width, command=onApply,
                image="::image::applyIcon", compound="left")
        }
        
        if(!WindowsP()) {
            if (!is.null(apply)){
                tkgrid(applyButton, cancelButton, OKbutton, sticky="w")
                tkgrid.configure(OKbutton, padx=c(6, 0))
            }
            else{
                tkgrid(cancelButton, OKbutton, sticky="w")
            }
            tkgrid.configure(cancelButton, padx=c(6, 6))
        }
        else {
            if (!is.null(apply)){
                tkgrid(OKbutton, cancelButton, applyButton, sticky="w")
                tkgrid.configure(applyButton, padx=c(6, 0))
            }
            else{
                tkgrid(OKbutton, cancelButton, sticky="w")
            }
            tkgrid.configure(OKbutton, padx=c(6, 6))
        }
        if (!is.null(reset) && memory) {
            if (! is.null(helpSubject)){
                tkgrid (helpButton, resetButton, pady=6)
            }
            else tkgrid (resetButton, pady=6)
            if (!WindowsP()) tkgrid.configure(resetButton, padx=c(0, 6))
        }
        else if (! is.null(helpSubject)){
            tkgrid(helpButton, pady=6)
        }
        tkgrid(leftButtonsBox, rightButtonsBox, pady=6, sticky="ew")
        if (!is.null(helpSubject)) tkgrid.configure(helpButton, padx=c(0, 18))
        else if (!is.null(reset) && memory) tkgrid.configure(resetButton, padx=c(0, 18))
        tkgrid.columnconfigure(buttonsFrame, 0, weight=1)
        tkgrid.columnconfigure(buttonsFrame, 1, weight=1)
        tkgrid.configure(leftButtonsBox, sticky="w")
        tkgrid.configure(rightButtonsBox, sticky="e")
    })

subOKCancelHelp <- defmacro(window=subdialog, helpSubject=NULL,
    expr={
        
        button.strings <- c("OK", "Cancel", 
                            if (!is.null(helpSubject)) "Help")
        width <- max(nchar(gettextRcmdr(button.strings)))
        if (WindowsP()) width <- width + 2
        subButtonsFrame <- tkframe(window)
        subLeftButtonsBox <- tkframe(subButtonsFrame)
        subRightButtonsBox <- tkframe(subButtonsFrame)
        subOKbutton <- buttonRcmdr(subRightButtonsBox, text=gettextRcmdr("OK"), foreground="darkgreen", width=width, command=onOKsub, default="active",
            image="::image::okIcon", compound="left")
        onCancelSub <- function() {
          if (exists(".subexit")){
            .subexit()
          }
          if (GrabFocus()) tkgrab.release(window)
          tkdestroy(window)
          tkfocus(CommanderWindow())
        }
        subCancelButton <- buttonRcmdr(subRightButtonsBox, text=gettextRcmdr("Cancel"), foreground="red", width=width, command=onCancelSub,
            image="::image::cancelIcon", compound="left") # borderwidth=3, 
        if (!is.null(helpSubject)){
            onHelpSub <- function(){
                if (GrabFocus() && (!WindowsP())) tkgrab.release(window)
                if (as.numeric(R.Version()$major) >= 2) print(help(helpSubject))
                else help(helpSubject)
            }
            subHelpButton <- buttonRcmdr(subLeftButtonsBox, text=gettextRcmdr("Help"), width=width, command=onHelpSub, 
                image="::image::helpIcon", compound="left")
        }
        if(!WindowsP()) {
            tkgrid(subCancelButton, subOKbutton, sticky="w")
            tkgrid.configure(subOKbutton, padx=c(6, 0))
        }
        else {
            tkgrid(subOKbutton, subCancelButton, sticky="w")
            tkgrid.configure(subOKbutton, padx=c(0, 6))
        }
        if (! is.null(helpSubject)){
            tkgrid(subHelpButton, pady=6, padx=c(0, 18))
        }
        tkgrid(subLeftButtonsBox, subRightButtonsBox, pady=6, sticky="ew")
        tkgrid.columnconfigure(subButtonsFrame, 0, weight=1)
        tkgrid.columnconfigure(subButtonsFrame, 1, weight=1)
        tkgrid.configure(subLeftButtonsBox, sticky="w")
        tkgrid.configure(subRightButtonsBox, sticky="e")
    })

checkActiveDataSet <- function(){
    if (activeDataSet() == FALSE) {
        tkfocus(CommanderWindow())
        FALSE
    }
    else TRUE
}

checkActiveModel <- function(){
    if (activeModel() == FALSE) {
        tkfocus(CommanderWindow())
        FALSE
    }
    else TRUE
}

checkFactors <- function(n=1){
    if (length(Factors()) < n){
        if (n > 1)
            Message(message=sprintf(gettextRcmdr("There fewer than %d factors in the active data set."), n),
                type="error")
        else Message(message=gettextRcmdr("There are no factors in the active data set."),
            type="error")
        tkfocus(CommanderWindow())
        FALSE
    }
    else TRUE
}

checkTwoLevelFactors <- function(n=1){
    if (length(TwoLevelFactors()) < n){
        if (n > 1)
            Message(message=sprintf(gettextRcmdr("There fewer than %d two-level factors in the active data set."), n),
                type="error")
        else Message(message=gettextRcmdr("There are no two-level factors in the active data set."),
            type="error")
        tkfocus(CommanderWindow())
        FALSE
    }
    else TRUE
}

checkNumeric <- function(n=1){
    if (length(Numeric()) < n){
        if (n > 1)
            Message(message=sprintf(gettextRcmdr("There fewer than %d numeric variables in the active data set."), n),
                type="error")
        else Message(message=gettextRcmdr("There are no numeric variables in the active data set."),
            type="error")
        tkfocus(CommanderWindow())
        FALSE
    }
    else TRUE
}

checkVariables <- function(n=1){
    if (length(Variables()) < n){
        if (n > 1)
            Message(message=sprintf(gettextRcmdr("There fewer than %d variables in the active data set."), n),
                type="error")
        else Message(message=gettextRcmdr("There are no variables in the active data set."),
            type="error")
        tkfocus(CommanderWindow())
        FALSE
    }
    else TRUE
}

commanderPosition <- function (){
    ID <- CommanderWindow()$ID
    as.numeric(c(tclvalue(.Tcl(paste("winfo rootx", ID))),
        tclvalue(.Tcl(paste("winfo rooty", ID)))))
}

initializeDialog <- defmacro(window=top, title="", offset=10, preventCrisp, 
    use.tabs=FALSE, notebook=notebook, tabs=c("dataTab", "optionsTab"),
    suppress.window.resize.buttons=TRUE,
    expr={
        if (getRcmdr("crisp.dialogs")) tclServiceMode(on=FALSE)
        window <- tktoplevel(borderwidth=10)
        if (use.tabs){
            notebook <- ttknotebook(window)
            for (tab in tabs) assign(tab, tkframe(window))
        }
        tkwm.title(window, title)
        location <- getRcmdr("open.dialog.here")
        position <- if (!is.null(location)) location
        else {
            pos <- offset + commanderPosition() 
            if (any(pos < 0)) "-50+50"
            else paste("+", paste(pos, collapse="+"), sep="")
        }
        tkwm.geometry(window, position)
        if (suppress.window.resize.buttons) tkwm.transient(window, CommanderWindow())
    }
)

closeDialog <- defmacro(window=top, release=TRUE,
    expr={
        if (release && GrabFocus()) tkgrab.release(window)
        tkdestroy(window)
    }
)

dialogSuffix <- defmacro(window=top, onOK=onOK, onCancel=onCancel, rows, columns, focus=top,
    bindReturn=TRUE, preventGrabFocus=FALSE, preventDoubleClick=FALSE,
    preventCrisp, 
    use.tabs=FALSE, notebook=notebook, tabs=c("dataTab", "optionsTab"), tab.names=c("Data", "Options"),
    grid.buttons=FALSE, resizable=FALSE, force.wait=FALSE,
    expr={
        if (use.tabs){
            for (i in 1:length(tabs)){
                tkadd(notebook, get(tabs[i]), text=gettextRcmdr(tab.names[i]), padding=6, sticky="nsew")
            }
            tkgrid(notebook, sticky="nsew")
        }
        if (grid.buttons) tkgrid(buttonsFrame, sticky = "ew")
        if (use.tabs && exists("dialog.values") && !is.null(dialog.values$initial.tab) && getRcmdr("restoreTab")) 
            tkselect(notebook, dialog.values$initial.tab)
        .Tcl("update idletasks")
        tkwm.resizable(window, as.numeric(resizable), as.numeric(resizable))
        if (bindReturn) tkbind(window, "<Return>", onOK)
        tkbind(window, "<Escape>", onCancel)
        if (getRcmdr("double.click") && (!preventDoubleClick)) tkbind(window, "<Double-ButtonPress-1>", onOK)
        tkwm.deiconify(window)
        # focus grabs appear to cause problems for some dialogs
        if (GrabFocus() && (!preventGrabFocus)) tkgrab.set(window)
        tkfocus(focus)
        if (getRcmdr("tkwait.dialog") || force.wait) tkwait.window(window)
        if (getRcmdr("crisp.dialogs")) tclServiceMode(on=TRUE)
#        tkwm.geometry(window, "")
    }
)

variableListBox <- function(parentWindow, variableList=Variables(), bg="white",
    selectmode="single", export="FALSE", initialSelection=NULL, listHeight=getRcmdr("variable.list.height"), title){
    if (selectmode == "multiple") selectmode <- getRcmdr("multiple.select.mode")
    if (length(variableList) == 1 && is.null(initialSelection)) initialSelection <- 0
    frame <- tkframe(parentWindow)
    minmax <- getRcmdr("variable.list.width")
    listbox <- tklistbox(frame, height=min(listHeight, length(variableList)),
        selectmode=selectmode, background=bg, exportselection=export, 
        width=min(max(minmax[1], 2 + nchar(variableList)), minmax[2]))
    scrollbar <- ttkscrollbar(frame, command=function(...) tkyview(listbox, ...))
    tkconfigure(listbox, yscrollcommand=function(...) tkset(scrollbar, ...))
    for (var in variableList) tkinsert(listbox, "end", var)
    if (is.numeric(initialSelection)) for (sel in initialSelection) tkselection.set(listbox, sel)
    firstChar <- tolower(substr(variableList, 1, 1))
    len <- length(variableList)
    onLetter <- function(letter){
        letter <- tolower(letter)
        current <- 1 + round(as.numeric(unlist(strsplit(tclvalue(tkyview(listbox) ), " "))[1])*len)
        mat <- match(letter, firstChar[-(1:current)])
        if (is.na(mat)) return()
        tkyview.scroll(listbox, mat, "units")
    }
    onA <- function() onLetter("a")
    onB <- function() onLetter("b")
    onC <- function() onLetter("c")
    onD <- function() onLetter("d")
    onE <- function() onLetter("e")
    onF <- function() onLetter("f")
    onG <- function() onLetter("g")
    onH <- function() onLetter("h")
    onI <- function() onLetter("i")
    onJ <- function() onLetter("j")
    onK <- function() onLetter("k")
    onL <- function() onLetter("l")
    onM <- function() onLetter("m")
    onN <- function() onLetter("n")
    onO <- function() onLetter("o")
    onP <- function() onLetter("p")
    onQ <- function() onLetter("q")
    onR <- function() onLetter("r")
    onS <- function() onLetter("s")
    onT <- function() onLetter("t")
    onU <- function() onLetter("u")
    onV <- function() onLetter("v")
    onW <- function() onLetter("w")
    onX <- function() onLetter("x")
    onY <- function() onLetter("y")
    onZ <- function() onLetter("z")
    for (letter in c(letters, LETTERS)){
        tkbind(listbox, paste("<", letter, ">", sep=""),
            get(paste("on", toupper(letter), sep="")))
    }
    onClick <- function() tkfocus(listbox)
    toggleSelection <- function(){
        active <- tclvalue(tkindex(listbox, "active"))
        selected <- tclvalue(tkcurselection(listbox))
        if (selected == active) tkselection.clear(listbox, "active") else tkselection.set(listbox, "active")
    }
    tkbind(listbox, "<ButtonPress-1>", onClick)
    if (selectmode == "single") tkbind(listbox, "<Control-ButtonPress-1>", toggleSelection)
    tkgrid(labelRcmdr(frame, text=title, fg=getRcmdr("title.color"), font="RcmdrTitleFont"), columnspan=2, sticky="w")
    tkgrid(listbox, scrollbar, sticky="nw")
    tkgrid.configure(scrollbar, sticky="wns")
    tkgrid.configure(listbox, sticky="ewns")
    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
}

variableComboBox <- function(parentWindow, variableList=Variables(),
                             export="FALSE", state="readonly",
                             initialSelection=gettextRcmdr(nullSelection),
                             title="",
                             nullSelection="<no variable selected>",
                             adjustWidth=FALSE){
  variableList <- c(gettextRcmdr(nullSelection), variableList)
  frame <- tkframe(parentWindow)
  combovar <- tclVar()
  tclvalue(combovar) <- initialSelection
  combobox <- if (adjustWidth){
    width <- max(nchar(variableList)) + 2
    ttkcombobox(frame, values=variableList, textvariable=combovar, 
                state=state, export=export, width=width)
  } else {
    ttkcombobox(frame, values=variableList, textvariable=combovar, 
                          state=state, export=export)
  }
  firstChar <- tolower(substr(variableList, 1, 1))
  onLetter <- function(letter){
    letter <- tolower(letter)
    current <- as.numeric(tcl(combobox, "current"))
    current <- if (current == -1) 1 else current + 1
    mat <- match(letter, firstChar[-(1:current)])
    if (is.na(mat)) return()
    tcl(combobox, "current", current + mat - 1)
  }
  onA <- function() onLetter("a")
  onB <- function() onLetter("b")
  onC <- function() onLetter("c")
  onD <- function() onLetter("d")
  onE <- function() onLetter("e")
  onF <- function() onLetter("f")
  onG <- function() onLetter("g")
  onH <- function() onLetter("h")
  onI <- function() onLetter("i")
  onJ <- function() onLetter("j")
  onK <- function() onLetter("k")
  onL <- function() onLetter("l")
  onM <- function() onLetter("m")
  onN <- function() onLetter("n")
  onO <- function() onLetter("o")
  onP <- function() onLetter("p")
  onQ <- function() onLetter("q")
  onR <- function() onLetter("r")
  onS <- function() onLetter("s")
  onT <- function() onLetter("t")
  onU <- function() onLetter("u")
  onV <- function() onLetter("v")
  onW <- function() onLetter("w")
  onX <- function() onLetter("x")
  onY <- function() onLetter("y")
  onZ <- function() onLetter("z")
  for (letter in c(letters, LETTERS)){
    tkbind(combobox, paste("<", letter, ">", sep=""),
           get(paste("on", toupper(letter), sep="")))
  }
  if (title != "") tkgrid(labelRcmdr(frame, text=title, fg=getRcmdr("title.color"), font="RcmdrTitleFont"), sticky="w") # , columnspan=2
  tkgrid(combobox, sticky="nw")
  result <- list(frame=frame, combobox=combobox, varlist=variableList, combovar=combovar)
  class(result) <- "combobox"
  result
}

getSelection.combobox <- function(object){
  tclvalue(object$combovar)
}

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

# This function modified based on code by Liviu Andronic (13 Dec 09) and on code by Milan Bouchet-Valat (29 Jun 12):
radioButtons <- defmacro(window=top, name, buttons, values=NULL, initialValue=..values[1], labels, 
    title="", title.color=getRcmdr("title.color"), right.buttons=FALSE,  command=function(){}, columns=1,
    expr={
        ..values <- if (is.null(values)) buttons else values
        ..frame <- paste(name, "Frame", sep="")
        assign(..frame, tkframe(window))
        ..frame.1 <- paste(name, "Frame.1", sep="")
        ..frame.2 <- paste(name, "Frame.2", sep="")
        ..frame.3 <- paste(name, "Frame.3", sep="")
        ..frame.4 <- paste(name, "Frame.4", sep="")
        assign(..frame.1, tkframe(eval(parse(text=..frame))))
        assign(..frame.2, tkframe(eval(parse(text=..frame))))
        assign(..frame.3, tkframe(eval(parse(text=..frame))))
        assign(..frame.4, tkframe(eval(parse(text=..frame))))
        ..variable <- paste(name, "Variable", sep="")
        assign(..variable, tclVar(initialValue))
        if(title != ""){
            tkgrid(labelRcmdr(eval(parse(text=..frame)), text=title, foreground=title.color, font="RcmdrTitleFont"), columnspan=2, sticky="w")
        }
        ..nbuttons <- length(buttons)
        for (i in 1:..nbuttons) {
            ..button <- paste(buttons[i], "Button", sep="")
            ..use.frame <- if (columns > 1) {
              paste0(..frame, ".", (i - 1) %% columns + 1)
            }  else ..frame
            if (right.buttons) {
                assign(..button, ttkradiobutton(eval(parse(text=..use.frame)), variable=eval(parse(text=..variable)), 
                    value=..values[i], command=command))
                tkgrid(labelRcmdr(eval(parse(text=..use.frame)), text=labels[i], justify="left"), eval(parse(text=..button)), sticky="nw")
            }
            else{
                assign(..button, ttkradiobutton(eval(parse(text=..use.frame)), variable=eval(parse(text=..variable)), 
                    value=..values[i], text=labels[i], command=command))
                tkgrid(eval(parse(text=..button)), sticky="nw")
            }
        }
        if (columns > 1){
          tkgrid(eval(parse(text=paste(name, "Frame.1", sep=""))),
                 eval(parse(text=paste(name, "Frame.2", sep=""))), 
                 if (columns > 2) eval(parse(text=paste(name, "Frame.3", sep=""))),
                 if (columns > 3) eval(parse(text=paste(name, "Frame.4", sep=""))),
                 sticky="nw", padx= if (columns > 1) "3" else "0")
          ..remainder <- ..nbuttons %% columns
          if (..remainder != 0){
            if (columns == 2) tkgrid(tklabel(eval(parse(text=paste(name, "Frame.2", sep=""))), text=" "), sticky="nw")
            else if (columns == 3) {
              tkgrid(tklabel(eval(parse(text=paste(name, "Frame.3", sep=""))), text=" "), sticky="nw")
              if (..remainder == 2) tkgrid(tklabel(eval(parse(text=paste(name, "Frame.2", sep=""))), text=" "), sticky="nw")
            }
            else {
              tkgrid(eval(parse(text=paste(name, "Frame.4", sep=""))), text=" ", sticky="nw")
              if (..remainder >= 2) tkgrid(tklabel(eval(parse(text=paste(name, "Frame.3", sep=""))), text=" "), sticky="nw")
              if (..remainder == 3) tkgrid(tklabel(eval(parse(text=paste(name, "Frame.2", sep=""))), text=" "), sticky="nw")
            }
          }
        }
    }
)


checkBoxes <- defmacro(window=top, frame, boxes, initialValues=NULL, labels, title=NULL, ttk=FALSE, columns=1,
    expr={
        ..initialValues <- if (is.null(initialValues)) rep("1", length(boxes)) else initialValues
        assign(frame, if (ttk) ttklabelframe(window, labelwidget=tklabel(window, text=title, 
                                          font="RcmdrTitleFont", foreground=getRcmdr("title.color"))) else tkframe(window))
        ..frame.1 <- paste(frame, "Frame.1", sep="")
        ..frame.2 <- paste(frame, "Frame.2", sep="")
        ..frame.3 <- paste(frame, "Frame.3", sep="")
        ..frame.4 <- paste(frame, "Frame.4", sep="")
        assign(..frame.1, tkframe(eval(parse(text=frame))))
        assign(..frame.2, tkframe(eval(parse(text=frame))))
        assign(..frame.3, tkframe(eval(parse(text=frame))))
        assign(..frame.4, tkframe(eval(parse(text=frame))))
        if (!is.null(title) && !ttk) tkgrid(labelRcmdr(eval(parse(text=frame)), text=title, fg=getRcmdr("title.color"), font="RcmdrTitleFont"), sticky="w")
        ..variables <- paste(boxes, "Variable", sep="")
        ..nboxes <- length(boxes)
        for (i in 1:..nboxes) {
            assign(..variables[i], tclVar(..initialValues[i]))
            ..checkBox <- paste(boxes[i], "CheckBox", sep="")
            ..use.frame <- if (columns > 1) {
              paste0(frame, "Frame.", (i - 1) %% columns + 1)
            }  else frame
            assign(..checkBox,
                ttkcheckbutton(eval(parse(text=..use.frame)), variable=eval(parse(text=..variables[i])), text=labels[i]))
            tkgrid(eval(parse(text=..checkBox)), sticky="nw")
        }
        if (columns > 1){
          tkgrid(eval(parse(text=paste(frame, "Frame.1", sep=""))),
                 eval(parse(text=paste(frame, "Frame.2", sep=""))), 
                 if (columns > 2) eval(parse(text=paste(frame, "Frame.3", sep=""))),
                 if (columns > 3) eval(parse(text=paste(frame, "Frame.4", sep=""))),
                 sticky="nw", padx= if (columns > 1) "3" else "0")
          ..remainder <- ..nboxes %% columns
          if (..remainder != 0){
            if (columns == 2) tkgrid(tklabel(eval(parse(text=paste(frame, "Frame.2", sep=""))), text=" "), sticky="nw")
            else if (columns == 3) {
              tkgrid(tklabel(eval(parse(text=paste(frame, "Frame.3", sep=""))), text=" "))
              if (..remainder == 2) tkgrid(tklabel(eval(parse(text=paste(frame, "Frame.2", sep=""))), text=" "), sticky="nw")
            }
            else {
              tkgrid(tklabel(eval(parse(text=paste(frame, "Frame.4", sep=""))), text=" "), sticky="nw")
              if (..remainder >= 2) tkgrid(tklabel(eval(parse(text=paste(frame, "Frame.3", sep=""))), text=" "), sticky="nw")
              if (..remainder == 3) tkgrid(tklabel(eval(parse(text=paste(frame, "Frame.2", sep=""))), text=" "), sticky="nw")
            }
          }
        }
    }
)

checkReplace <- function(name, type=gettextRcmdr("Variable")){
    RcmdrTkmessageBox(message=sprintf(gettextRcmdr("%s %s already exists.\nOverwrite %s?"),
        type, name, tolower(type)), icon="warning", type="yesno", default="no")
}

errorCondition <- defmacro(window=top, recall=NULL, message, model=FALSE,
   expr={
     putRcmdr("cancelDialogReopen", TRUE)
     if (model) putRcmdr("modelNumber", getRcmdr("modelNumber") - 1)
     if (!is.null(window)){
       if (GrabFocus()) tkgrab.release(window)
       tkdestroy(window)
     }
     Message(message=message, type="error")
     if (!is.null(recall)) recall()
     else tkfocus(CommanderWindow())
   })

subsetBox <- defmacro(window=top, subset.expression=NULL, model=FALSE,
    expr={
        subsetVariable <- if (!is.null(subset.expression)) tclVar(gettextRcmdr(subset.expression))
        else if (model){
            if (currentModel && currentFields$subset != "")
                tclVar(currentFields$subset) else tclVar(gettextRcmdr("<all valid cases>"))
        }
        else tclVar(gettextRcmdr("<all valid cases>"))
        subsetFrame <- tkframe(window)
        subsetEntry <- ttkentry(subsetFrame, width="20", textvariable=subsetVariable)
        subsetScroll <- ttkscrollbar(subsetFrame, orient="horizontal",
            command=function(...) tkxview(subsetEntry, ...))
        tkconfigure(subsetEntry, xscrollcommand=function(...) tkset(subsetScroll, ...))
        tkgrid(labelRcmdr(subsetFrame, text=gettextRcmdr("Subset expression"), fg=getRcmdr("title.color"), font="RcmdrTitleFont"), sticky="w")
        tkgrid(subsetEntry, sticky="ew")
        tkgrid(subsetScroll, sticky="ew")
        tkgrid.columnconfigure(subsetFrame, 0, weight=1)
    })


groupsBox <- defmacro(recall=NULL, label=gettextRcmdr("Plot by:"), initialLabel=gettextRcmdr("Plot by groups"),
                      errorText=gettextRcmdr("There are no factors in the active data set."),
                      variables=Factors(), plotLinesByGroup=FALSE, positionLegend=FALSE, plotLinesByGroupsText=gettextRcmdr("Plot lines by group"),
                      initialGroup=NULL, initialLinesByGroup=1, window=top,
                      expr={
                          env <- environment()
                          .groups <- if (is.null(initialGroup)) FALSE else initialGroup
                          .linesByGroup <- initialLinesByGroup == 1
                          .groupsLabel <- tclVar(if (!is.null(initialGroup)) initialLabel else paste(initialLabel, "...", sep=""))
                          .factors <- variables
                          onGroups <- function(){
                              if (length(.factors) == 0){
                                  errorCondition(recall=recall, message=errorText)
                                  return()
                              }
                              initializeDialog(subdialog, title=gettextRcmdr("Groups"))
                              groupsBox <- variableListBox(subdialog, .factors, title=gettextRcmdr("Groups variable (pick one)"),
                                                           initialSelection=varPosn(initialGroup, "factor"))
                              if (plotLinesByGroup){
                                  linesByGroupFrame <- tkframe(subdialog)
                                  linesByGroup <- tclVar(if(initialLinesByGroup == 1) "1" else "0")
                                  linesCheckBox <- ttkcheckbutton(linesByGroupFrame, variable=linesByGroup)
                                  tkgrid(labelRcmdr(linesByGroupFrame, text=plotLinesByGroupsText), linesCheckBox, sticky="w")
                              }
                              onOKsub <- function() {
                                  groups <- getSelection(groupsBox)
                                  if (length(groups) == 0){
                                      assign(".groups", FALSE, envir=env)
                                      tclvalue(.groupsLabel) <- paste(gettextRcmdr("Plot by groups"), "...", sep="")
                                      tkconfigure(groupsButton, foreground="black")
                                      if (GrabFocus()) tkgrab.release(subdialog)
                                      tkdestroy(subdialog)
                                      tkwm.deiconify(top)
                                      if (GrabFocus()) tkgrab.set(top)
                                      tkfocus(top)
                                      tkwait.window(top)
                                      return()
                                  }
                                  assign(".groups", groups, envir=env)
                                  tclvalue(.groupsLabel) <- paste(label, groups)
                                  tkconfigure(groupsButton, foreground=getRcmdr("title.color"))
                                  tkconfigure(groupsButton, font="RcmdrTitleFont")
                                  if (plotLinesByGroup) {
                                      lines <- as.character("1" == tclvalue(linesByGroup))
                                      assign(".linesByGroup", lines, envir=env)
                                  }
                                  if (GrabFocus()) tkgrab.release(subdialog)
                                  tkdestroy(subdialog)
                                  tkwm.deiconify(top)
                                  if (GrabFocus()) tkgrab.set(top)
                                  tkfocus(top)
                                  tkwait.window(top)
                              }
                              subOKCancelHelp()
                              tkgrid(getFrame(groupsBox), sticky="nw")
                              if (plotLinesByGroup) tkgrid(linesByGroupFrame, sticky="w")
                              tkgrid(subButtonsFrame, sticky="ew")
                              if (positionLegend) tkgrid(labelRcmdr(subdialog, text=gettextRcmdr("Position legend with mouse click"), fg=getRcmdr("title.color"), font="RcmdrTitleFont"))
                              dialogSuffix(subdialog, onOK=onOKsub, focus=subdialog, force.wait=TRUE)
                          }
                          groupsFrame <- tkframe(window)
                          groupsButton <- tkbutton(groupsFrame, textvariable=.groupsLabel, command=onGroups)
                          if (!is.null(initialGroup)) tkconfigure(groupsButton, foreground=getRcmdr("title.color"), font="RcmdrTitleFont")
                          tkgrid(groupsButton, sticky="we")
                          tkgrid.columnconfigure(groupsFrame, 0, weight=1)
                      })


groupsLabel <- defmacro(frame=top, groupsBox=groupsBox, columnspan=1, initialText=NULL, ratio=FALSE,
    expr={
        initial.label <- if (exists("dialog.values")) dialog.values$initial.label else NULL
        if  (is.null(initial.label)) {
            group <- getSelection(groupsBox)
            initial.label <- if (length(group) == 0) NULL 
            else {
                levels <- eval(parse(text = paste("levels(", ActiveDataSet(), 
                    "$", group, ")", sep = "")))
                paste(levels[1], if (ratio) "/" else "-", levels[2])
            }
        }
        groupsFrame <- tkframe(frame)
        .groupsLabel <- if (!is.null(initialText)) initialText 
        else if (is.null(initial.label)) gettextRcmdr("<No groups selected>") 
        else initial.label
        groupsLabel <- labelRcmdr(groupsFrame, text=.groupsLabel)
        tkgrid(labelRcmdr(groupsFrame, text=if (ratio) gettextRcmdr("Ratio: ") else gettextRcmdr("Difference: "), fg=getRcmdr("title.color"), font="RcmdrTitleFont"), groupsLabel, sticky="w")
        tkgrid(groupsFrame, sticky="w", columnspan=columnspan)
        onSelect <- function(){
            group <- getSelection(groupsBox)
            if (length(group) == 0) {
                .groupsLabel <<- gettextRcmdr("<No groups selected>") 
            }
            else {
                levels <- eval(parse(text=paste("levels(", ActiveDataSet(), "$", group, ")", sep="")))
                .groupsLabel <<- paste(levels[1], if (ratio) "/" else "-", levels[2])
            }
            tkconfigure(groupsLabel, text=.groupsLabel)
        }
        tkbind(groupsBox$listbox, "<ButtonRelease-1>", onSelect)
    })

modelFormula <- defmacro(frame=top, hasLhs=TRUE, rhsExtras=NULL, formulaLabel=gettextRcmdr("Model Formula"), showBar=FALSE,
                         expr={
  .rhsExtras <- if (is.null(rhsExtras)) hasLhs else rhsExtras
  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 <- Variables()
  word <- paste("\\[", gettextRcmdr("factor"), "\\]", sep="")
  variables <- paste(.variables,
                     ifelse(is.element(.variables, Factors()), paste("[", gettextRcmdr("factor"), "]", sep=""), ""))
  xBox <- variableListBox(frame, variables, selectmode="multiple", title=gettextRcmdr("Variables (double-click to formula)"))
  onDoubleClick <- if (!hasLhs){
    function(){
      var <- getSelection(xBox)
      tkselection.clear(xBox$listbox, "0", "end")            		
      if (length(grep(word, var)) == 1) var <- sub(word, "",  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 if (check.char == "|") paste(rhs, var)
      else paste(rhs, "+", var)
      tkicursor(rhsEntry, "end")
      tkxview.moveto(rhsEntry, "1")
    }
  }
  else{
    function(){
      var <- getSelection(xBox)
      which <- tkcurselection(xBox$listbox)
      tkselection.clear(xBox$listbox, "0", "end")
      if (length(grep(word, var)) == 1) var <- sub(word, "",  var)
      lhs <- tclvalue(lhsVariable)
      if (lhs == "" || tclvalue(tkselection.present(lhsEntry)) == "1"){
        tclvalue(lhsVariable) <- var
        tkselection.clear(lhsEntry)
        tkfocus(rhsEntry)
      }
      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 if (check.char == "|") paste(rhs, var)
        else paste(rhs, "+", var)
      }
      tkicursor(rhsEntry, "end")
      tkxview.moveto(rhsEntry, "1")
    }
  }
  tkbind(xBox$listbox, "<Double-ButtonPress-1>", onDoubleClick)
  onPlus <- function(){
    rhs <- tclvalue(rhsVariable)
    var <- getSelection(xBox)
    tkselection.clear(xBox$listbox, "0", "end")										
    if ((check <- !checkAddOperator(rhs)) && length(var) == 0) return()
    if (length(var) > 1){
      if (length(grep(word, var)) > 0) var <- sub(word, "",  var)
      if (length(var) > 1) var <- paste(var, collapse=" + ")
    }
    tclvalue(rhsVariable) <- paste(rhs, if (!check) " + ", var, sep="")
    tkicursor(rhsEntry, "end")
    tkxview.moveto(rhsEntry, "1")
  }
  onTimes <- function(){
    rhs <- tclvalue(rhsVariable)
    var <- getSelection(xBox)
    tkselection.clear(xBox$listbox, "0", "end")						
    if ((check <- !checkAddOperator(rhs)) && length(var) == 0) return()
    if (length(var) > 1){
      if (length(grep(word, var)) > 0) var <- sub(word, "",  var)
      var <- trim.blanks(var)
      if (length(var) > 1) var <- paste(var, collapse="*")
      tclvalue(rhsVariable) <- paste(rhs, if (!check) " + ", var, sep="")
    }
    else tclvalue(rhsVariable) <- paste(rhs, if (!check) "*", sep="")
    tkicursor(rhsEntry, "end")
    tkxview.moveto(rhsEntry, "1")
  }
  onColon <- function(){
    rhs <- tclvalue(rhsVariable)
    var <- getSelection(xBox)
    tkselection.clear(xBox$listbox, "0", "end")						
    if ((check <- !checkAddOperator(rhs)) && length(var) == 0) return()
    if (length(var) > 1){
      if (length(grep(word, var)) > 0) var <- sub(word, "",  var)
      var <- trim.blanks(var)
      if (length(var) > 1) var <- paste(var, collapse=":")
      tclvalue(rhsVariable) <- paste(rhs, if (!check) " + ", var, sep="")
    }
    else tclvalue(rhsVariable) <- paste(rhs, if (!check) ":", 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")
  }
  onBar <- 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)
    nchar.rhs <- nchar(rhs)
    if (substr(rhs, nchar.rhs, nchar.rhs) == "+") rhs <- paste0(rhs, " ")
    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)
  splinePolyFrame <- tkframe(outerOperatorsFrame)
  plusButton <- buttonRcmdr(operatorsFrame, text="+", width="3", command=onPlus)
  timesButton <- buttonRcmdr(operatorsFrame, text="*", width="3", command=onTimes)
  colonButton <- buttonRcmdr(operatorsFrame, text=":", width="3", command=onColon)
  slashButton <- buttonRcmdr(operatorsFrame, text="/", width="3", command=onSlash)
  barButton <- buttonRcmdr(operatorsFrame, text="|", width="3", command=onBar)
  inButton <- buttonRcmdr(operatorsFrame, text="%in%", width="5", command=onIn)
  minusButton <- buttonRcmdr(operatorsFrame, text="-", width="3", command=onMinus)
  powerButton <- buttonRcmdr(operatorsFrame, text="^", width="3", command=onPower)
  leftParenButton <- buttonRcmdr(operatorsFrame, text="(", width="3", command=onLeftParen)
  rightParenButton <- buttonRcmdr(operatorsFrame, text=")", width="3", command=onRightParen)
  onBSpline <- function(){
    rhs <- tclvalue(rhsVariable)
    var <- getSelection(xBox)
    tkselection.clear(xBox$listbox, "0", "end")
    if (length(var) == 0) var <- " "
    if (grepl("\\[factor\\]", var)){
      Message("spline requires a numeric variable", type="error")
      return()
    }
    if (length(var) > 1){
      Message("cannot select more than one variable", type="error")
      return()
    }
    check <- !checkAddOperator(rhs)
    tclvalue(rhsVariable) <- paste(rhs, 
                                   if (!check) paste(" + bs(", var, ", df=", tclvalue(dfSplineVar), ")", sep="") 
                                   else paste(" bs(", var, ", df=", tclvalue(dfSplineVar), ")", sep=""),
                                   sep="")
    tkicursor(rhsEntry, "end")
    tkxview.moveto(rhsEntry, "1")
  }
  onNatSline <- function(){
    rhs <- tclvalue(rhsVariable)
    var <- getSelection(xBox)
    tkselection.clear(xBox$listbox, "0", "end")
    if (length(var) == 0) var <- " "
    if (grepl("\\[factor\\]", var)){
      Message("spline requires a numeric variable", type="error")
      return()
    }
    if (length(var) > 1){
      Message("cannot select more than one variable", type="error")
      return()
    }
    check <- !checkAddOperator(rhs)
    tclvalue(rhsVariable) <- paste(rhs, 
                                   if (!check) paste(" + ns(", var, ", df=", tclvalue(dfSplineVar), ")", sep="") 
                                   else paste(" ns(", var, ", df=", tclvalue(dfSplineVar), ")", sep=""),
                                   sep="")
    tkicursor(rhsEntry, "end")
    tkxview.moveto(rhsEntry, "1")
  }
  onPoly <- function(){
    rhs <- tclvalue(rhsVariable)
    var <- getSelection(xBox)
    tkselection.clear(xBox$listbox, "0", "end")
    if (length(var) == 0) var <- " "
    if (grepl("\\[factor\\]", var)){
      Message("polynomial requires a numeric variable", type="error")
      return()
    }
    if (length(var) > 1){
      Message("cannot select more than one variable", type="error")
      return()
    }
    check <- !checkAddOperator(rhs)
    tclvalue(rhsVariable) <- paste(rhs, 
                                   if (!check) paste(" + poly(", var, ", degree=", tclvalue(degPolyVar), ")", sep="") 
                                   else paste(" poly(", var, ", degree=", tclvalue(degPolyVar), ")", sep=""),
                                   sep="")
    tkicursor(rhsEntry, "end")
    tkxview.moveto(rhsEntry, "1")
  }
  onRawPoly <- function(){
    rhs <- tclvalue(rhsVariable)
    var <- getSelection(xBox)
    tkselection.clear(xBox$listbox, "0", "end")
    if (length(var) == 0) var <- " "
    if (grepl("\\[factor\\]", var)){
      Message("polynomial requires a numeric variable", type="error")
      return()
    }
    if (length(var) > 1){
      Message("cannot select more than one variable", type="error")
      return()
    }
    check <- !checkAddOperator(rhs)
    tclvalue(rhsVariable) <- paste(rhs, 
                                   if (!check) paste(" + poly(", var, ", degree=", tclvalue(degPolyVar), ", raw=TRUE)", sep="") 
                                   else paste(" poly(", var, ", degree=", tclvalue(degPolyVar), ", raw=TRUE)", sep=""),
                                   sep="")
    tkicursor(rhsEntry, "end")
    tkxview.moveto(rhsEntry, "1")
  }
  bsplineButton <- tkbutton(splinePolyFrame, text=gettextRcmdr("B-spline\n"), width="10", relief="groove", command=onBSpline)
  nsplineButton <- tkbutton(splinePolyFrame, text=gettextRcmdr("natural\nspline"), width="10", relief="groove", command=onNatSline)
  polyButton <- tkbutton(splinePolyFrame, text=gettextRcmdr("orthogonal\npolynomial"), width="10", relief="groove", command=onPoly)
  RawPolyButton <- tkbutton(splinePolyFrame, text=gettextRcmdr("raw\npolynomial"), width="10", relief="groove", command=onRawPoly)
  dfSplineVar <- tclVar("5")
  degPolyVar <- tclVar("2")
  dfDegFrame <- tkframe(outerOperatorsFrame)
  dfSplineSpin <- tkspinbox(dfDegFrame, textvariable=dfSplineVar, state="readonly", from=2, to=10, width=2)
  degPolySpin <- tkspinbox(dfDegFrame, textvariable=degPolyVar, state="readonly", from=2, to=5, width=2)
  tkgrid(plusButton, timesButton, colonButton, slashButton, if (showBar) barButton else NULL, inButton, minusButton,
         powerButton, leftParenButton, rightParenButton, sticky="w")
  tkgrid(labelRcmdr(dfDegFrame, text=gettextRcmdr("df for splines: ")), dfSplineSpin,  sticky="se")
  tkgrid(labelRcmdr(dfDegFrame, text=gettextRcmdr("deg. for polynomials: ")), degPolySpin, sticky="se")
  formulaFrame <- tkframe(frame)
  formulaFrameMain <- tkframe(formulaFrame)
  onFormulaHelp <- function () print(help("formula"))
  formulaHelpButton <- buttonRcmdr(formulaFrame, text=gettextRcmdr("Model formula\nhelp"), command=onFormulaHelp,
                                   image="::image::helpIcon", compound="left")
  if (hasLhs){
    tkgrid(labelRcmdr(outerOperatorsFrame, text=gettextRcmdr("Model Formula"), 
                      fg=getRcmdr("title.color"), font="RcmdrTitleFont"), sticky="w")
    tkgrid(labelRcmdr(outerOperatorsFrame, text=gettextRcmdr("Operators (click to formula):  ")), operatorsFrame, sticky="nw")
    if (.rhsExtras){
      tkgrid(bsplineButton, nsplineButton, polyButton, RawPolyButton, sticky="nw")
      tkgrid(labelRcmdr(outerOperatorsFrame, text=gettextRcmdr("Splines/Polynomials:\n(select variable and click)")), 
             splinePolyFrame, dfDegFrame, sticky="nw")
    }
    lhsVariable <- if (currentModel) tclVar(currentFields$lhs) else tclVar("")
    rhsVariable <- if (currentModel) tclVar(currentFields$rhs) else tclVar("")
    rhsEntry <- ttkentry(formulaFrameMain, width="75", textvariable=rhsVariable)
    rhsXscroll <- ttkscrollbar(formulaFrameMain,
                               orient="horizontal", command=function(...) tkxview(rhsEntry, ...))
    tkconfigure(rhsEntry, xscrollcommand=function(...) tkset(rhsXscroll, ...))
    lhsEntry <- ttkentry(formulaFrameMain, width="10", textvariable=lhsVariable)
    lhsScroll <- ttkscrollbar(formulaFrameMain,
                              orient="horizontal", command=function(...) tkxview(lhsEntry, ...))
    tkconfigure(lhsEntry, xscrollcommand=function(...) tkset(lhsScroll, ...))
    tkgrid(lhsEntry, labelRcmdr(formulaFrameMain, text=" ~    "), rhsEntry, sticky="w")
    tkgrid(lhsScroll, labelRcmdr(formulaFrameMain, text=""), rhsXscroll, sticky="w")
    tkgrid.configure(lhsScroll, sticky="ew")
    tkgrid(formulaFrameMain, labelRcmdr(formulaFrame, text="  "), formulaHelpButton, sticky="nw")
  }
  else{
    if (.rhsExtras){
      tkgrid(labelRcmdr(outerOperatorsFrame, text=formulaLabel, 
                        fg=getRcmdr("title.color"), font="RcmdrTitleFont"), sticky="w")
      tkgrid(labelRcmdr(outerOperatorsFrame, text=gettextRcmdr("Operators (click to formula):  ")), operatorsFrame, sticky="nw")
      tkgrid(bsplineButton, nsplineButton, polyButton, RawPolyButton, sticky="nw")
      tkgrid(labelRcmdr(outerOperatorsFrame, text=gettextRcmdr("Splines/Polynomials:\n(select variable and click)")), 
             splinePolyFrame, dfDegFrame, sticky="nw")
    }
    rhsVariable <- if (currentModel) tclVar(currentFields$rhs) else tclVar("")
    rhsEntry <- ttkentry(formulaFrameMain, width="75", textvariable=rhsVariable)
    rhsXscroll <- ttkscrollbar(formulaFrameMain,
                               orient="horizontal", command=function(...) tkxview(rhsEntry, ...))
    tkconfigure(rhsEntry, xscrollcommand=function(...) tkset(rhsXscroll, ...))
    tkgrid(labelRcmdr(formulaFrameMain, text="   ~ "), rhsEntry, sticky="w")
    tkgrid(labelRcmdr(formulaFrameMain, text=""), rhsXscroll, sticky="w")
    tkgrid(formulaFrameMain, labelRcmdr(formulaFrame, text="  "), formulaHelpButton, sticky="nw")
  }
  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, reportError=TRUE,
    expr={
        msg <- if (is.null(message)) sprintf(gettextRcmdr("No appropriate %s method exists\nfor a model of this class."), generic)
        else message
        method <- exists.method(generic, get(object), default=default, strict=strict)
        if ((!method) && reportError) Message(message=msg, type="error")
        method
    }
)

checkClass <- defmacro(object, class, message=NULL,
    expr={
        msg <- if (is.null(message)) sprintf(gettextRcmdr('The model is not of class "%s".'), class)
        else message
        properClass <- class(get(object))[1] == class
        if (!properClass) Message(message=msg, type="error")
        properClass
    }
)

# the following function is from John Chambers (plus new test for R 2.4.0)

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

.RcmdrEnv <- new.env(parent=emptyenv())

RcmdrEnv <- function() .RcmdrEnv

putRcmdr <- function(x, value) assign(x, value, envir=RcmdrEnv())

getRcmdr <- function(x, mode="any", fail=TRUE){
    if ((!fail) && (!exists(x, mode=mode, envir=RcmdrEnv(), inherits=FALSE))) return(NULL)
    get(x, envir=RcmdrEnv(), mode=mode, inherits=FALSE)
}


RcmdrTclSet <- function(name, value){
    name <- ls(unclass(getRcmdr(name))$env)
    tcl("set", name, value)
}

# functions to store or retrieve Rcmdr state information

Variables <- function(names){
    if (missing(names)) getRcmdr("variables")
    else putRcmdr("variables", names)
}

Numeric <- function(names){
    if (missing(names)) getRcmdr("numeric")
    else putRcmdr("numeric", names)
}

Character <- function(names){
  if (missing(names)) getRcmdr("character")
  else putRcmdr("character", names)
}

Factors <- function(names){
    if (missing(names)) getRcmdr("factors")
    else putRcmdr("factors", names)
}

TwoLevelFactors <- function(names){
    if (missing(names)) getRcmdr("twoLevelFactors")
    else putRcmdr("twoLevelFactors", names)
}

# The following two functions were modified by Erich Neuwrith
#  and subsequently by John Fox (23 July 07)
#  and Milan Bouchet-Valat (27 March 14)

ActiveDataSet <- function(name){
    if (missing(name)) {
        temp <- getRcmdr(".activeDataSet")
        if (is.null(temp))
            return(NULL)
        else
            if (!exists(temp) || !is.data.frame(get(temp,envir=.GlobalEnv))) {
                Message(sprintf(gettextRcmdr("the dataset %s is no longer available"),
                    temp), type="error")
                putRcmdr(".activeDataSet", NULL)
                Variables(NULL)
                Numeric(NULL)
                Factors(NULL)
                TwoLevelFactors(NULL)
                Character(NULL)
                RcmdrTclSet("dataSetName", gettextRcmdr("<No active dataset>"))
                putRcmdr(".activeModel", NULL)
                putRcmdr("nrow", NULL)
                putRcmdr("ncol", NULL)
                RcmdrTclSet("modelName", gettextRcmdr("<No active model>"))
                tkconfigure(getRcmdr("dataSetLabel"), foreground="red") 
                tkconfigure(getRcmdr("modelLabel"), foreground="red") 
                activateMenus()
                if (getRcmdr("suppress.menus") && RExcelSupported()) return(NULL)
            }
        return(temp)
    }
    else {
        putRcmdr(".activeDataSet", name)

      if(!is.null(name)) {
        Variables(listVariables(name))
        Numeric(listNumeric(name))
        Factors(listFactors(name))
        TwoLevelFactors(listTwoLevelFactors(name))
        DiscreteNumeric(listDiscreteNumeric(name))
        Character(listCharacter(name))
        open.showData.windows <- getRcmdr("open.showData.windows")
        if (!is.null(open.showData.windows) && name %in% names(open.showData.windows)
            && open.showData.windows[[name]]$ID %in% as.character(tkwinfo("children", "."))){
          ID <- open.showData.windows[[name]]$ID
          posn <- as.numeric(c(tclvalue(.Tcl(paste("winfo x", ID))),
                       tclvalue(.Tcl(paste("winfo y", ID)))))
          posn <- paste("+", paste(posn, collapse = "+"), sep = "")
          tkdestroy(open.showData.windows[[name]])
          suppress <- if(getRcmdr("suppress.X11.warnings")) ", suppress.X11.warnings=FALSE" else ""
          view.height <- max(as.numeric(getRcmdr("output.height")) + as.numeric(getRcmdr("log.height")), 10)
          command <- paste("showData(as.data.frame(", name, "), title='", name, 
                           "', placement='", posn, "', font=getRcmdr('logFont'), maxwidth=",
                           getRcmdr("log.width"), ", maxheight=", view.height, suppress, ")", sep="")
          window <- justDoIt(command)
          open.showData.windows[[ActiveDataSet()]] <- window
          putRcmdr("open.showData.windows", open.showData.windows)
        }
        
      }
        else {
            Variables(NULL)
            Numeric(NULL)
            Factors(NULL)
            TwoLevelFactors(NULL)
            DiscreteNumeric(NULL)
            Character(NULL)
            RcmdrTclSet("dataSetName", gettextRcmdr("<No active dataset>"))
            putRcmdr(".activeModel", NULL)
            putRcmdr("nrow", NULL)
            putRcmdr("ncol", NULL)
            RcmdrTclSet("modelName", gettextRcmdr("<No active model>"))
            tkconfigure(getRcmdr("dataSetLabel"), foreground="red") 
            tkconfigure(getRcmdr("modelLabel"), foreground="red") 
            activateMenus()
            if (getRcmdr("suppress.menus") && RExcelSupported()) return(NULL)
        }
    }
}

ActiveModel <- function(name){
    if (missing(name)) {
        temp <- getRcmdr(".activeModel")
        if (is.null(temp))
            return(NULL)
        else
            if (!exists(temp) || !is.model(get(temp,envir=.GlobalEnv))) {
                Message(sprintf(gettextRcmdr("the model %s is no longer available"),
                    temp), type="error")
                putRcmdr(".activeModel", NULL)
                RcmdrTclSet("modelName", gettextRcmdr("<No active model>"))
                tkconfigure(getRcmdr("modelLabel"), foreground="red")
                activateMenus()
                return(NULL)
            }
        else return(temp)
    }
    else putRcmdr(".activeModel", name)
}

GrabFocus <- function(value){
    if (missing(value)) getRcmdr("grab.focus")
    else putRcmdr("grab.focus", value)
}

UpdateModelNumber <- function(increment=1){
    modelNumber <- getRcmdr("modelNumber")
    modelNumber <- modelNumber + increment
    if (modelNumber < 1) modelNumber <- 1 # sanity check
    putRcmdr("modelNumber", modelNumber)
}

CommanderWindow <- function() getRcmdr("commanderWindow")

LogWindow <- function() getRcmdr("logWindow")

RmdWindow <- function() getRcmdr("RmdWindow")

RnwWindow <- function() getRcmdr("RnwWindow")

OutputWindow <- function() getRcmdr("outputWindow")

MessagesWindow <- function() getRcmdr("messagesWindow")

# some predicates for the menu system

activeDataSetP <- function() !is.null(ActiveDataSet())

dataSetsP <- function(n=1){
    datasets <- listDataSets()
    (!is.null(datasets)) && length(datasets) >= n
}

numericP <- function(n=1) activeDataSetP() && length(listNumeric()) >= n

factorsP <- function(n=1) activeDataSetP() && length(listFactors()) >= n

characterP <- function(n=1) activeDataSetP() && length(listCharacter()) >= n

twoLevelFactorsP <- function(n=1) activeDataSetP() && length(listTwoLevelFactors()) >= n

modelsP <- function(n=1) activeDataSetP() && length(listAllModels()) >= n

activeModelP <- function() !is.null(ActiveModel())

lmP <- function() activeModelP() && any(class(get(ActiveModel()))[1] == c('lm', 'aov'))

glmP <- function() activeModelP() && class(get(ActiveModel()))[1] == 'glm'

logLikP <- function() activeModelP() && exists.method("logLik", get(ActiveModel()))

anovaP <- function() activeModelP() && exists.method("anova", get(ActiveModel()))

EffectP <- function() activeModelP() && exists.method("Effect", get(ActiveModel()), default=FALSE)

polrP <- function() activeModelP() && class(get(ActiveModel()))[1] == 'polr'

multinomP <- function() activeModelP() && class(get(ActiveModel()))[1] == 'multinom'

hclustSolutionsP <- function() length(listHclustSolutions()) > 0

MacOSXP <- function(release) {
    sys <- Sys.info()
    OSX <- !is.null(sys) && length(grep("[Dd]arwin", sys["sysname"]) > 0)
    if (missing(release)) OSX
    else (OSX && release <= sys["release"])
}

packageAvailable <- function(name) 0 != length(find.package(name, quiet=TRUE))

rglLoaded <- function() 0 != length(grep("^rgl", loadedNamespaces()))

activateMenus <- function(){
    if (getRcmdr("suppress.menus")) return()
    for (item in getRcmdr("Menus")){
        if (item$activation()) .Tcl(paste(item$ID, " entryconfigure ", item$position - 1," -state normal", sep=""))
        else .Tcl(paste(item$ID, " entryconfigure ", item$position - 1," -state disabled", sep=""))
    }
}

# for internationalization

gettextRcmdr <- function(...) gettext(..., domain="R-Rcmdr")

gettextMenus <- function(...){
    text <- gettextRcmdr(...)
    plugins <- getOption("Rcmdr")$plugins
    if (is.null(plugins)) return(text)
    plugins <- paste("R-", plugins, sep="")
    for (plugin in plugins){
        text <- gettext(text, domain=plugin)
    }
    text
}

English <- function() {
    env <- Sys.getenv()
    names(env) <- toupper(names(env))
    LANG <- env["LANGUAGE"]
    LC_CTYPE <- Sys.getlocale("LC_CTYPE")
    if (!is.na(LANG)) length(grep("^en", LANG, ignore.case=TRUE)) > 0
    else LC_CTYPE == "C" || length(grep("^en", LC_CTYPE, ignore.case=TRUE)) > 0
}

# to replace tkmessageBox on non-English Windows systems,
#  to allow for translation of button text

# nMacOSDisplays <- function(){
#   if (!MacOSXP()) return(0)
#   sum(grepl("^ *Display Type:", system("system_profiler SPDisplaysDataType", 
#                                        intern=TRUE)))
# }

# cross-platform message box with custom icons

RcmdrTkmessageBox <- function(message, icon=c("info", "question", "warning",
    "error"), type=c("okcancel", "yesno", "ok"), default, title) {
  icon <- match.arg(icon)
  type <- match.arg(type)
  if (missing(title)){
    title <- switch(icon,
                    info=gettextRcmdr("Information"),
                    question=gettextRcmdr("Question"),
                    warning=gettextRcmdr("Warning"),
                    error=gettextRcmdr("Error")
                    )
  }
  icon.image <- switch(icon,
                       info="::image::infoIcon",
                       question="::image::questionIcon",
                       warning="::image::warningIcon",
                       error="::image::errorIcon"
  )
    # if ((nMacOSDisplays() < 2) && ((English()) || (!WindowsP()))){
    #     if (missing(default)){
    #         default <- switch(type,
    #             okcancel="ok",
    #             yesno="yes",
    #             ok="ok")}
    #     return(tkmessageBox(message=message, icon=icon, type=type,
    #         default=default, title=title))
    # }
    initializeDialog(messageBox, title=title)
    messageFrame <- tkframe(messageBox, borderwidth=5)
    buttonFrame <- tkframe(messageBox,  borderwidth=5)
    if (icon != "question") tkbell()
    result <- tclVar()
    iconColor <- switch(icon, info=getRcmdr("title.color"), question=getRcmdr("title.color"), warning="black",
        error="red")
    onOK <- function() {
        if (GrabFocus()) tkgrab.release(messageBox)
        tkdestroy(messageBox)
        tkfocus(CommanderWindow())
        tclvalue(result) <- "ok"
    }
    OKbutton <- buttonRcmdr(buttonFrame, text=gettextRcmdr("OK"),
        foreground="darkgreen", width="12", command=onOK, borderwidth=3,
        default=if (missing(default)) "active"
        else if (default == "ok") "active" else "normal")
    onCancel <- function() {
        if (GrabFocus()) tkgrab.release(messageBox)
        tkdestroy(messageBox)
        tkfocus(CommanderWindow())
        tclvalue(result) <- "cancel"
    }
    cancelButton <- buttonRcmdr(buttonFrame, text=gettextRcmdr("Cancel"),
        foreground="red", width="12", command=onCancel, borderwidth=3,
        default=if (missing(default)) "normal"
        else if (default == "cancel") "active" else "normal")
    onYes <- function() {
        if (GrabFocus()) tkgrab.release(messageBox)
        tkdestroy(messageBox)
        tkfocus(CommanderWindow())
        tclvalue(result) <- "yes"
    }
    yesButton <- buttonRcmdr(buttonFrame, text=gettextRcmdr("Yes"),
        foreground="darkgreen", width="12", command=onYes, borderwidth=3,
        default=if (missing(default)) "active"
        else if (default == "yes") "active" else "normal")
    onNo <- function() {
        if (GrabFocus()) tkgrab.release(messageBox)
        tkdestroy(messageBox)
        tkfocus(CommanderWindow())
        tclvalue(result) <- "no"
    }
    noButton <- buttonRcmdr(buttonFrame, text=gettextRcmdr("No"),
        foreground="red", width="12", command=onNo, borderwidth=3,
        default=if (missing(default)) "normal"
        else if (default == "no") "active" else "normal")
    ## FIXME -- left in old style -- FIXED
#    tkgrid(tklabel(messageFrame, bitmap=icon, fg=iconColor),
    tkgrid(tklabel(messageFrame, image=icon.image, fg=iconColor, 
                   text=paste0("    ", message),
                   compound="left"))
        # tklabel(messageFrame, text="    "),
        # tklabel(messageFrame, text=message))
    tkgrid(messageFrame)
    switch(type,
        okcancel = {
            tkgrid(OKbutton, labelRcmdr(buttonFrame, text="    "), cancelButton)
            if (missing(default) || default == "ok") tkbind(messageBox, "<Return>",
                onOK)
            else if (default == "cancel") tkbind(messageBox, "<Return>", onCancel)
        },
        yesno =  {
            tkgrid(yesButton, labelRcmdr(buttonFrame, text="    "), noButton)
            if (missing(default) || default == "yes") tkbind(messageBox, "<Return>",
                onYes)
            else if (default == "no") tkbind(messageBox, "<Return>", onNo)
        },
        ok = {
            tkgrid(OKbutton)
            if (missing(default) || default == "ok") tkbind(messageBox, "<Return>",
                onOK)
        }
    )
    tkgrid(buttonFrame)
    dialogSuffix(messageBox, focus=messageBox, bindReturn=FALSE, force.wait=TRUE)
    result
}

# The following function was contributed by Matthieu Lesnoff (added 20 July 06)

trim.col.na <- function(dat){
    # Remove variables with only missing values (occurs sometimes with modified Excel file)
    colsup <- NULL
    for (i in 1:ncol(dat))
    {
        if (length(dat[is.na(dat[,i])==T,i]) ==length(dat[,i]))
            colsup <- c(colsup,i)
    }
    if (length(colsup) > 0)
        dat <- dat[,-colsup]
    dat
}

# check whether packages are available

packagesAvailable <- function(packages){
    sapply(sapply(packages, find.package, quiet=TRUE),
        function(x) length(x) != 0)
}

# insert a row (or rows) in a matrix or data frame

insertRows <- function(object1, object2, where=NULL, ...){
    if (ncol(object1) != ncol(object2))
        stop(gettextRcmdr("objects have different numbers of columns"))
    if (!(TRUE == all.equal(colnames(object1), colnames(object2))))
        stop(gettextRcmdr("objects have different column names"))
    n <- nrow(object1)
    if (is.null(where) || where >= n) rbind(object1, object2)
    else if (where < 1) rbind(object2, object1)
    else rbind(object1[1:floor(where),], object2,
        object1[(floor(where) + 1):n,])
}

# functions for handling Rcmdr plug-in packages

# the following function based on a suggestion by Brian Ripley

listPlugins <- function(loaded=FALSE){
    plugins <- unlist(lapply(.libPaths(),
        function(x) Sys.glob(file.path(x, "*/etc/menus.txt"))))
    plugins <- sub(".*/([^/]*)/etc/menus.txt", "\\1", plugins)
    if (loaded) plugins else sort(setdiff(plugins, .packages()))
}


loadPlugins <- function(){
    plugins <- listPlugins()
    initializeDialog(title=gettextRcmdr("Load Plug-ins"))
    packagesBox <- variableListBox(top, plugins, title=gettextRcmdr("Plug-ins (pick one or more)"),
        selectmode="multiple", listHeight=10)
    onOK <- function(){
        plugins <- getSelection(packagesBox)
        closeDialog(top)
        if (length(plugins) == 0){
            errorCondition(recall=loadPlugins, message=gettextRcmdr("You must select at least one plug-in."))
            return()
        }
        opts <- options("Rcmdr")
        opts$Rcmdr$plugins <- c(plugins, opts$Rcmdr$plugins)
        options(opts)
        for (plugin in plugins) {
            command <- paste('library("', plugin, '", character.only=TRUE)', sep="")
            justDoIt(command)
        }
        Message(paste(gettextRcmdr("Plug-ins loaded:"), paste(plugins, collapse=", ")), type="note")
        response <- tkmessageBox(message=paste(gettextRcmdr(
            "The plug-in(s) will not be available until the Commander is restarted.\nRestart now?")),
            icon="question", type="yesno")
        if (tclvalue(response) == "yes") {
            putRcmdr("autoRestart", TRUE)
            closeCommander(ask=FALSE)
            Commander()
        }
    }
    OKCancelHelp(helpSubject="Plugins")
    tkgrid(getFrame(packagesBox), sticky="nw")
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix()
}

# the following two functions contributed by Erich Neuwirth (added 22 July 07)

whitespaceonly <- function(str) sub('[[:space:]]+$', '', str) == ''

is.model <- function(object) {
    any(class(object) %in% getRcmdr("modelClasses"))
}

# the following lines, adding support for ttk widgets, adapted from code by Brian Ripley
if (!(as.character(tcl("info", "tclversion")) >= "8.5" && getRversion() >= "2.7.0")){
    buttonRcmdr <- tkbutton
    labelRcmdr <- tklabel
    ttkentry <- function(parent, ...) tkentry(parent, ...)
    ttkframe <- tkframe
    ttkradiobutton <- tkradiobutton
    ttkscrollbar <- function(...) tkscrollbar(..., repeatinterval=5)
} else {
    buttonRcmdr <- function(..., borderwidth, fg, foreground, relief) ttkbutton(...)
    labelRcmdr <- function(..., fg)
        if(missing(fg)) ttklabel(...) else ttklabel(..., foreground=fg)
    # add context menu to ttk text entry boxes
    ttkentry <- function(parent, ...) {
        widget <- tcltk::ttkentry(parent, ...)
        wid <- widget$ID
        onCopy <- function(){
            if ("0" == tclvalue(.Tcl(paste(wid, "selection present")))) return()
            sel.1 <- tclvalue(.Tcl(paste(wid, "index sel.first")))
            sel.2 <- tclvalue(.Tcl(paste(wid, "index sel.last")))
            text <- tclvalue(tkget(widget))
            text <- substr(text, as.numeric(sel.1) + 1, as.numeric(sel.2) + 1)
            tkclipboard.clear()
            tkclipboard.append(text)
        }
        onDelete <- function(){
            if ("0" == tclvalue(.Tcl(paste(wid, "selection present")))) return()
            sel.1 <- tclvalue(.Tcl(paste(wid, "index sel.first")))
            sel.2 <- tclvalue(.Tcl(paste(wid, "index sel.last")))
            .Tcl(paste(wid, "delete", sel.1, sel.2))
        }
        onCut <- function(){
            onCopy()
            onDelete()
        }
        onPaste <- function(){
            onDelete()
            text <- tclvalue(.Tcl("selection get -selection CLIPBOARD"))
            if (length(text) == 0) return()
            .Tcl(paste(wid, "insert", "insert", text))
        }
        onSelectAll <- function() {
            .Tcl(paste(wid, "selection range 0 end"))
            tkfocus(widget)
        }
        contextMenuEntry <- function(){
            contextMenu <- tkmenu(tkmenu(widget), tearoff=FALSE)
            tkadd(contextMenu, "command", label=gettextRcmdr("Cut"), command=onCut)
            tkadd(contextMenu, "command", label=gettextRcmdr("Copy"), command=onCopy)
            tkadd(contextMenu, "command", label=gettextRcmdr("Paste"), command=onPaste)
            tkadd(contextMenu, "command", label=gettextRcmdr("Delete"), command=onDelete)
            tkadd(contextMenu, "command", label=gettextRcmdr("Select all"), command=onSelectAll)
            tkpopup(contextMenu, tkwinfo("pointerx", widget), tkwinfo("pointery", widget))
        }
        tkbind(widget, "<ButtonPress-3>", contextMenuEntry)
        tkbind(widget, "<Control-ButtonPress-1>", contextMenuEntry)
        if (MacOSXP()){
            tkbind(widget, "<Meta-ButtonPress-1>", contextMenuEntry)
        }
        widget
    }
}

# Label looking like that of a TtkLabelFrame
titleLabel <- function(...) labelRcmdr(..., font="RcmdrTitleFont", fg=getRcmdr("title.color"))

# the following function alters the default behaviour of tclvalue() by trimming leading and trailing blanks

tclvalue <- function(x) trim.blanks(tcltk::tclvalue(x))

# the following function splits a character string at blanks and commas according to width

splitCmd <- function(cmd, width=getOption("width") - 4, at="[ ,]"){
  if (length(cmd) > 1) cmd <- paste(cmd, collapse="\n")
  if (length(grep("\n", cmd)) > 0){
    cmds <- strsplit(cmd, "\n")[[1]]
    allcmds <- character(length(cmds))
    for (i in 1:length(cmds))
      allcmds[i] <- splitCmd(cmds[i], width=width, at=at)
    return(paste(allcmds, collapse="\n"))
  }
  if (nchar(cmd) <= width) return(cmd)
  where <- gregexpr(at, cmd)[[1]]
  if (where[1] < 0) return(cmd)
  singleQuotes <- gregexpr("'", cmd)[[1]]
  doubleQuotes <- gregexpr('"', cmd)[[1]]
  comment <- regexpr("#", cmd)
  if (singleQuotes[1] > 0 && (singleQuotes[1] < doubleQuotes[1] || doubleQuotes[1] < 0 ) && (singleQuotes[1] < comment[1] || comment[1] < 0 )){
    nquotes <- length(singleQuotes)
    if (nquotes < 2) stop("unbalanced quotes")
    for(i in seq(nquotes/2))
      where[(where > singleQuotes[2 * i - 1]) & (where < singleQuotes[2 * i])] <- NA
    where <- na.omit(where)
  }
  else if (doubleQuotes[1] > 0 && (doubleQuotes[1] < singleQuotes[1] || singleQuotes[1] < 0) && (doubleQuotes[1] < comment[1] || comment[1] < 0 )){
    nquotes <- length(doubleQuotes)
    if (nquotes < 2) stop("unbalanced quotes")
    for(i in seq(nquotes/2))
      where[(where > doubleQuotes[2 * i - 1]) & (where < doubleQuotes[2 * i])] <- NA
    where <- na.omit(where)
  }
  else if (comment > 0){
    where[where > comment] <- NA
    where <- na.omit(where)
  }
  if (length(where) == 0) return(cmd)
  where2 <- where[where <= width]
  where2 <- if (length(where2) == 0) where[1]
  else where2[length(where2)]
  paste(substr(cmd, 1, where2), "\n  ",
        Recall(substr(cmd, where2 + 1, nchar(cmd)), width, at), sep="")
}

# splitCmd <- function(cmd, width=getOption("width")){
#   cmd <- tidy_source(text=cmd, width.cutoff=width, output=FALSE)$text.tidy
#   if (length(cmd) > 1) cmd <- paste(cmd, collapse="; ")
#   cmd
# }

# the following function sorts names containing numerals "more naturally" than does sort()

sortVarNames <- function(x){
    sort.helper <- function(x){
        prefix <- strsplit(x, "[0-9]+")
        prefix <- sapply(prefix, "[", 1)
        prefix[is.na(prefix)] <- ""
        suffix <- strsplit(x, "[^0-9]+")
        suffix <- as.numeric(sapply(suffix, "[", 2))
        suffix[is.na(suffix)] <- -Inf
        remainder <- sub("[^0-9]+", "", x)
        remainder <- sub("[0-9]+", "", remainder)
        if (all (remainder == "")) list(prefix, suffix)
        else c(list(prefix, suffix), Recall(remainder))
    }
    ord <- do.call("order", sort.helper(x))
    x[ord]
}

# to load packages

Library <- function(package, pos=length(search()), rmd=TRUE){
    dependencies <- tools::package_dependencies(package, db=getRcmdr("installed.packages"), which="Depends")
    loaded <- search()
    loaded <- loaded[grep("^package:", loaded)]
    loaded <- sub("^package:", "", loaded)
    if (!getRcmdr("suppress.X11.warnings")){
        messages.connection <- file(open="w+")
        sink(messages.connection, type="message")
        on.exit({
            sink(type="message")
            close(messages.connection)
        })
    }
    if (!(package %in% loaded)){
        for (pkg in dependencies[[package]]){
            Library(pkg, pos=pos, rmd=rmd)
        }
        command <- paste("library(", package, ", pos=", pos, ")", sep="")
        logger(command, rmd=rmd)
        result <- try(eval(parse(text=command), envir=.GlobalEnv), silent=TRUE)
        if (class(result)[1] ==  "try-error"){
            Message(message=paste(strsplit(result, ":")[[1]][2]), type="error")
            tkfocus(CommanderWindow())
            return("error")
        }
        return(package)
    }
    else return(invisible(NULL))
}

# start help system

startHelp <- function(){
    Sys.sleep(2)
    help.start()
}

# dialog memory support

putDialog <- function (dialog, values=NULL, resettable=TRUE){
    if (resettable){
        dialog.values <- getRcmdr("dialog.values")
        dialog.values[[dialog]] <- values
        putRcmdr("dialog.values", dialog.values)
    }
    else{
        dialog.values <- getRcmdr("dialog.values.noreset")
        dialog.values[[dialog]] <- values
        putRcmdr("dialog.values.noreset", dialog.values)
    }
}

getDialog <- function(dialog, defaults=NULL){
    values <- getRcmdr("dialog.values.noreset")[[dialog]]
    if (getRcmdr("retain.selections") && !is.null(values)) return(values)
    values <- getRcmdr("dialog.values")[[dialog]]
    if (!getRcmdr("retain.selections") || is.null(values)) return(defaults)
    else return (values)
}

varPosn <- function(variables, 
    type=c("all", "factor", "numeric", "nonfactor", "twoLevelFactor"), vars=NULL){
    if (is.null(variables)) return(NULL)
    type <- match.arg(type)
    if (is.null(vars)) vars <- switch(type,
        all = Variables(),
        factor = Factors(),
        numeric = Numeric(),
        nonfactor = setdiff(Variables(), Factors()),
        twoLevelFactor = TwoLevelFactors()
    )
    if (any(!variables %in% vars)) NULL
    else apply(outer(variables, vars, "=="), 1, which) - 1
}

flushDialogMemory <- function(what){
    if (missing(what)) putRcmdr("dialog.values", list())
    else{
        dialog.values <- getRcmdr("dialog.values")
        dialog.values.noreset <- getRcmdr("dialog.values.noreset")
        for (dialog in what){
            dialog.values[dialog] <- NULL
            dialog.values.noreset[dialog] <- NULL
        }
        putRcmdr("dialog.values", dialog.values)
        putRcmdr("dialog.values.noreset", dialog.values.noreset)
    }
}

# for assignments to the global environment

gassign <- function(x, value){
    if (!(is.valid.name(x))) stop("argument x not a valid R name")
    G <- .GlobalEnv
    assign(x, value, envir=G)
}


tkfocus <- function(...) tcl("focus", ...)

tkspinbox <- function(parent, ...) tkwidget(parent, "spinbox", ...)

# the following two functions adapted from Milan Bouchet-Valat

WindowsP <- function() {
    .Platform$OS.type == "windows"
}

X11P <- function(){
    .Platform$GUI == "X11"
}

RStudioP <- function() nzchar(Sys.getenv("RSTUDIO_USER_IDENTITY")) # to detect RStudio

# the following functions to support R Markdown

MarkdownEditorWindow <- function(){
    if (getRcmdr("Markdown.editor.open")) getRcmdr("editor.text")
    else NULL
}

knitrEditorWindow <- function(){
    if (getRcmdr("knitr.editor.open")) getRcmdr("editor.text")
    else NULL
}

trimTrailingNewLines <- function(string){
  repeat{
    where <- regexpr("\n\n[ ]*$", string)
    if (where == -1) break
    string <- paste0(substr(string, 1, where - 1), substr(string, where + 2, nchar(string)))
  }
  paste0(string, "\n")
}

suppressMarkdown <- function(command){
    attr(command, "suppressRmd") <- TRUE
    command
}

beginRmdBlock <- function(){
    .rmd <- RmdWindow()
    last2 <- tclvalue(tkget(.rmd, "end -2 chars", "end"))
    if (last2 != "\n\n") tkinsert(.rmd, "end", "\n")
    tkinsert(.rmd, "end", "\n")
    # if (getRcmdr("rgl.command") && getRcmdr("use.rgl")) tkinsert(.rmd, "end", "```{r, webgl=TRUE}\n")
    #   else tkinsert(.rmd, "end", "```{r}\n")
    tkinsert(.rmd, "end", "```{r}\n")
    if (getRcmdr("Markdown.editor.open")){
        .markdown.editor <- MarkdownEditorWindow()
        last2 <- tclvalue(tkget(.markdown.editor, "end -2 chars", "end"))
        if (last2 != "\n\n") tkinsert(.markdown.editor, "end", "\n")
        tkinsert(.markdown.editor, "end", "\n")
        # if (getRcmdr("rgl.command") && getRcmdr("use.rgl")) tkinsert(.markdown.editor, "end", "```{r, webgl=TRUE}\n")
        # else tkinsert(.markdown.editor, "end", "```{r}\n")
        tkinsert(.markdown.editor, "end", "```{r}\n")
    }
}

endRmdBlock <- function(){
    .rmd <- RmdWindow()
    rmd <- tclvalue(tkget(.rmd, "1.0", "end"))
    rmd <- if (getRcmdr("rgl.command") && getRcmdr("use.rgl")){
      paste(substring(rmd, 1, nchar(rmd) - 1), "rglwidget()\n```\n", sep="")
    } else {
      paste(substring(rmd, 1, nchar(rmd) - 1), "```\n", sep="")
    }
    rmd <- trimHangingEndRmdBlock(rmd)
    rmd <- trimTrailingNewLines(rmd)
    tkdelete(.rmd, "1.0", "end")
    tkinsert(.rmd, "end", rmd)
    tkyview.moveto(.rmd, 1)
    if (getRcmdr("Markdown.editor.open")){
        .markdown.editor<- MarkdownEditorWindow()
        rmd <- tclvalue(tkget(.markdown.editor, "1.0", "end"))
        rmd <- if (getRcmdr("rgl.command") && getRcmdr("use.rgl")){
          paste(substring(rmd, 1, nchar(rmd) - 1), "rglwidget()\n```\n", sep="")
        } else {
          paste(substring(rmd, 1, nchar(rmd) - 1), "```\n", sep="")
        }
        rmd <- trimHangingEndRmdBlock(rmd)
        rmd <- trimTrailingNewLines(rmd)
        tkdelete(.markdown.editor, "1.0", "end")
        tkinsert(.markdown.editor, "end", rmd)
        tkyview.moveto(.markdown.editor, 1)
    }
}

removeNullRmdBlocks <- function(){
    .rmd <- RmdWindow()
    rmd <- tclvalue(tkget(.rmd, "1.0", "end"))
    rmd <- gsub("\n+$", "\n", rmd)
    rmd <- gsub("```\\{r\\}\n$", "", rmd)
    rmd <- gsub("```\\{r\\}\n```\n$", "", rmd)
    tkdelete(.rmd, "1.0", "end")
    tkinsert(.rmd, "end", rmd)
    tkyview.moveto(.rmd, 1)
    if (getRcmdr("Markdown.editor.open")){
        .markdown.editor<- MarkdownEditorWindow()
        rmd <- tclvalue(tkget(.markdown.editor, "1.0", "end"))
        rmd <- gsub("\n+$", "\n", rmd)
        rmd <- gsub("```\\{r\\}\n$", "", rmd)
        rmd <- gsub("```\\{r\\}\n```\n$", "", rmd)
        tkdelete(.markdown.editor, "1.0", "end")
        tkinsert(.markdown.editor, "end", rmd)
        tkyview.moveto(.markdown.editor, 1)
    }
}

removeStrayRmdBlocks <- function(){
    .rmd <- RmdWindow()
    rmd <- tclvalue(tkget(.rmd, "1.0", "end"))
    rmd <- strsplit(rmd, "\\n")[[1]]
    starts <- grep("^```\\{r.*\\}$", rmd)
    ends  <- grep("^```$", rmd)
    n.ends <- length(ends)
    j <- 1
    if (length(starts) > 1){
        for (i in 1:(length(starts) - 1)){
            if (j > n.ends || ends[j] > starts[i + 1]) {
                rmd[starts[i]] <- ""
            }
            else {
                j <- j + 1
                next
            }
        }
    }
    else return()
    rmd <- paste(rmd, collapse="\n")
    tkdelete(.rmd, "1.0", "end")
    tkinsert(.rmd, "end", rmd)
    tkyview.moveto(.rmd, 1)
    if (getRcmdr("Markdown.editor.open")){
        .markdown.editor<- MarkdownEditorWindow()
        rmd <- tclvalue(tkget(.markdown.editor, "1.0", "end"))
        rmd <- strsplit(rmd, "\\n")[[1]]
        starts <- grep("^```\\{r.*\\}$", rmd)
        ends  <- grep("^```$", rmd)
        n.ends <- length(ends)
        j <- 1
        if (length(starts) > 1){
            for (i in 1:(length(starts) - 1)){
                if (j > n.ends || ends[j] > starts[i + 1]) {
                    rmd[starts[i]] <- ""
                }
                else {
                    j <- j + 1
                    next
                }
            }
        }
        else return()
        rmd <- paste(rmd, collapse="\n")
        tkdelete(.markdown.editor, "1.0", "end")
        tkinsert(.markdown.editor, "end", rmd)
        tkyview.moveto(.markdown.editor, 1)
    }
}

cleanUpArg <- function(arg){
  arg <- gsub("cbind\\(", "", arg)
  arg <- gsub("\\[", "", arg)
  arg <- gsub("\\]", "", arg)
  if (grepl("~", arg)) return(trim.blanks(arg))
  arg <- gsub("\\(", "", arg)
  arg <- gsub("\\)", "", arg)
  arg <- gsub("\\$", "\\: ", arg)
  trim.blanks(arg)
}

findCommandName <- function(command){
  assigned <- NA
  command <- trim.blanks(command)
  command <- gsub("\n", " ", command)
  where <- regexpr("\\(", command)
  if (where < 0) return(NA)
  args <- trim.blanks(strsplit(
    substring(command, where + 1, nchar(command)), ",")[[1]])
  command <- substring(command, 1, where - 1)
#  args <- gsub("[()]", "", args)
  for (i in 1:length(args)){
    arg <- args[i]
    where <- regexpr("=", arg)
    args[i] <- if (where < 0) cleanUpArg(arg)
    else cleanUpArg(substring(arg, where + 1, nchar(arg)))
  }
  where <- regexpr("<-", command)
  if (where > 0) {
    assigned <- trim.blanks(substring(command, 1, where - 1))
    command <- trim.blanks(substring(command, where + 2, nchar(command)))
  }
  if (command == "") return(NA)
  operation <-  getRcmdr("Operations")[command, , drop=FALSE]
  commandName <- operation[, "section.title"]
  if (is.na(commandName)) {
    return(command)
  } else if (commandName == ""){
    return(NA)
  } else {
    if (!is.na(operation[, "assign"]) && operation[, "assign"])
      commandName <- paste0(gettextRmdHeader(commandName), ": ", assigned)
    if (!is.na(arg <- operation[, "argument"]))
      arg <- as.numeric(strsplit(arg, " ")[[1]])
    arg <- arg[arg <= length(args)]
    if (!is.na(arg[1])) commandName <- paste0(gettextRmdHeader(commandName), ": ", paste(args[arg], collapse=", "))
    return(commandName)
  }
}


enterMarkdown <- function(command){
    if (!getRcmdr("use.markdown")) return()
    .rmd <- RmdWindow()
    command <- splitCmd(command)
    beginRmdBlock()
    tkinsert(.rmd, "end", paste(command, "\n", sep=""))
    tkyview.moveto(.rmd, 1)
    putRcmdr("markdown.output", TRUE)
    if (getRcmdr("Markdown.editor.open")){
        .markdown.editor <- MarkdownEditorWindow()
        tkinsert(.markdown.editor, "end", paste(command, "\n", sep=""))
        tkyview.moveto(.markdown.editor, 1)
    }
    endRmdBlock()
    command
}

trimHangingEndRmdBlock <- function(string){
    loc.ends <- gregexpr("```\n", string)[[1]]
    n.ends <- length(loc.ends)
    if (n.ends > 1){
        substr <- substring(string, loc.ends[n.ends - 1], loc.ends[n.ends])
        if (!grepl("```\\{r\\}|```\\{r, webgl=TRUE\\}", substr)){
            string <- cutstring(string, loc.ends[n.ends], loc.ends[n.ends] + 3)
        }
    }
    string
}

removeLastRmdBlock <- function(){
    .rmd <- RmdWindow()    
    rmd <- tclvalue(tkget(.rmd, "1.0", "end"))
    start <- gregexpr("```\\{r\\}\n|```\\{r, webgl=TRUE\\}\n", rmd)
    if (start[[1]][1] > 0){
        start <- start[[1]]
        start <- start[length(start)]
        tail <- substring(rmd, start, nchar(rmd))
        end <- gregexpr("```\n", tail)
        end <- if (end[[1]][1] > 0) end[[1]][1] + 3 else nchar(tail)
        rmd <- cutstring(rmd, start, start + end)
        rmd <- trimTrailingNewLines(rmd)
        tkdelete(.rmd, "1.0", "end")
        tkinsert(.rmd, "end", rmd)
        tkyview.moveto(.rmd, 1)
    }
    if (getRcmdr("Markdown.editor.open")){
        .markdown.editor <- MarkdownEditorWindow()
        rmd <- tclvalue(tkget(.markdown.editor, "1.0", "end"))
        start <- gregexpr("```\\{r\\}\n|```\\{r, webgl=TRUE\\}\n", rmd)
        if (start[[1]][1] > 0){
            start <- start[[1]]
            start <- start[length(start)]
            tail <- substring(rmd, start, nchar(rmd))
            end <- gregexpr("```\n", tail)
            end <- if (end[[1]][1] > 0) end[[1]][1] + 3 else nchar(tail)
            rmd <- cutstring(rmd, start, start + end)
            rmd <- trimTrailingNewLines(rmd)
            tkdelete(.markdown.editor, "1.0", "end")
            tkinsert(.markdown.editor, "end", rmd)
            tkyview.moveto(.markdown.editor, 1)
        }
    }
}

# removeRglRmdBlocks <- function(string){
#   repeat{
#     match <- regexpr("```\\{r, webgl=TRUE\\}\n", string)
#     if (match == -1) return(trimTrailingNewLines(string))
#     substring <- cutstring(string, end=match)
#     match.end <- regexpr("```\n", substring)
#     string <- cutstring(string, match, match + match.end + 3)
#   }
# }

removeLastRmdSection <- function(){
  .rmd <- RmdWindow()    
  rmd <- tclvalue(tkget(.rmd, "1.0", "end"))
  start <- gregexpr("\n#[^\n]*", rmd)
  if (start[[1]][1] > 0){
    start <- start[[1]]
    start <- start[length(start)] + 1
    tail <- substring(rmd, start, nchar(rmd))
    end <- gregexpr("\n", tail)
    end <- if (end[[1]][1] > 0) end[[1]][1] else nchar(tail)
    rmd <- cutstring(rmd, start, start + end - 1)
    rmd <- trimTrailingNewLines(rmd)
    tkdelete(.rmd, "1.0", "end")
    tkinsert(.rmd, "end", rmd)
    tkyview.moveto(.rmd, 1)
  }
  if (getRcmdr("Markdown.editor.open")){
    .markdown.editor <- MarkdownEditorWindow()
    rmd <- tclvalue(tkget(.markdown.editor, "1.0", "end"))
    start <- gregexpr("\n#[^\n]*", rmd)
    if (start[[1]][1] > 0){
      start <- start[[1]] + 1
      start <- start[length(start)]
      tail <- substring(rmd, start, nchar(rmd))
      end <- gregexpr("\n", tail)
      end <- if (end[[1]][1] > 0) end[[1]][1] else nchar(tail)
      rmd <- cutstring(rmd, start, start + end - 1)
      rmd <- trimTrailingNewLines(rmd)
      tkdelete(.markdown.editor, "1.0", "end")
      tkinsert(.markdown.editor, "end", rmd)
      tkyview.moveto(.markdown.editor, 1)
    }
  }
}


cutstring <- function(x, start=1, end=nchar(x)){
    one <- if (start > 1) substr(x, 1, start - 1) else ""
    two <- if (end < nchar(x)) substr(x, end + 1, nchar(x)) else ""
    paste0(one, two)
}

MarkdownP <- function(){
    getRcmdr("log.commands") && getRcmdr("use.markdown")
}

compileRmd <- function() {
    save.rglopt <- options(rgl.useNULL=TRUE)
    on.exit(options(save.rglopt))
    ChooseOutputFormat <- function(){
        initializeDialog(title=gettextRcmdr("Select Output Format"))
        format <- getRcmdr("rmd.output.format")
        putRcmdr("abort.compile.rmd", TRUE)
        hasLatex <- getRcmdr("capabilities")$pdflatex
        radioButtons(name="formatButtons", 
            buttons=c("html", if (hasLatex) "pdf", "docx", "rtf"), 
            initialValue=format,
            labels=c(gettextRcmdr(".html (web page)"), 
                if (hasLatex) gettextRcmdr(".pdf (PDF file)"), gettextRcmdr(".docx (Word file)"), gettextRcmdr(".rtf (rich text file)")))
        onOK <- function(){
            putRcmdr("abort.compile.rmd", FALSE)
            format <- tclvalue(formatButtonsVariable)
            putRcmdr("rmd.output.format", format)
            closeDialog()
        }
        OKCancelHelp()
        tkgrid(formatButtonsFrame, sticky="w")
        dialogSuffix(force.wait=TRUE, grid.buttons=TRUE)
    }
    .RmdFile <- getRcmdr("RmdFileName")
    rmdDir <- dirname(.RmdFile)
    saveDir <- setwd(rmdDir)
    on.exit(setwd(saveDir), add=TRUE)
    fig.files <- list.files("./figure")
    fig.files <- fig.files[grep("^unnamed-chunk-[0-9]*\\..*$", fig.files)]
    if (length(fig.files) != 0) {
        response <- tkmessageBox(message = gettextRcmdr("Delete previously created R Markdown\ngraphics files (recommended)?"),
            icon = "question", type = "okcancel", default = "ok")
        if (tclvalue(response) == "ok") unlink(paste("./figure/", fig.files, sep=""))
    }
    removeStrayRmdBlocks()
    lines <- tclvalue(tkget(RmdWindow(), "1.0", "end"))
    lines <- sub("date: \"AUTOMATIC\"", paste("date: \"", as.character(Sys.time()), "\"", sep=""), lines)
    .filename <- sub("\\.Rmd$", "", trim.blanks(.RmdFile))
    writeLines(lines, .RmdFile)
    defaults <- list(
      command.sections = TRUE, section.level=3, toc=TRUE, toc_float=TRUE, toc_depth=3, number_sections=FALSE
    )
    options <- applyDefaultValues(getRcmdr("rmarkdown.output"), defaults)
    if (getRcmdr("capabilities")$pandoc){
        ChooseOutputFormat()
        if (getRcmdr("abort.compile.rmd")){
            putRcmdr("abort.compile.rmd", NULL)
            return()
        }
        else putRcmdr("abort.compile.rmd", NULL)
        format <- getRcmdr("rmd.output.format")
        switch(format,
            html = {
                rmarkdown::render(.RmdFile, rmarkdown::html_document(toc=options$toc, 
                                                                     toc_float=options$toc_float,
                                                                     toc_depth=options$toc_depth,
                                                                     number_sections=options$number_sections))
                .html.file <- paste(.filename, ".html", sep="")
                .html.file.location <- paste("file:///", normalizePath(.html.file), sep="")
                Message(paste(gettextRcmdr("HTML file written to:"), normalizePath(.html.file)), type="note")
                browseURL(.html.file.location)
            },
            pdf = {
                # lines <- removeRglRmdBlocks(lines)
                writeLines(lines, .RmdFile)
                rmarkdown::render(.RmdFile, rmarkdown::pdf_document(toc=options$toc,
                                                                    toc_depth=options$toc_depth,
                                                                    number_sections=options$number_sections))
                .pdf.file <- paste(.filename, ".pdf", sep="")
                .pdf.file.location <- paste("file:///", normalizePath(.pdf.file), sep="")
                Message(paste(gettextRcmdr("PDF file written to:"), normalizePath(.pdf.file)), type="note")
                browseURL(.pdf.file.location)
            },
            docx = {
              # lines <- removeRglRmdBlocks(lines)
              writeLines(lines, .RmdFile)
                rmarkdown::render(.RmdFile, rmarkdown::word_document(toc=options$toc,
                                                                     toc_depth=options$toc_depth,
                                                                     number_sections=options$number_sections))
                .docx.file <- paste(.filename, ".docx", sep="")
                Message(paste(gettextRcmdr("Word file written to:"), normalizePath(.docx.file)), type="note")
            },
            rtf = {
              # lines <- removeRglRmdBlocks(lines)
              writeLines(lines, .RmdFile)
              rmarkdown::render(.RmdFile, rmarkdown::rtf_document(toc=options$toc,
                                                                  toc_depth=options$toc_depth,
                                                                  number_sections=options$number_sections))
              .rtf.file <- paste(.filename, ".rtf", sep="")
              Message(paste(gettextRcmdr("Rich text file written to:"), normalizePath(.rtf.file)), type="note")
            }
        )
    }
    else{
        if (options$toc) {
          save.opt <- options(markdown.HTML.options= "toc")
          on.exit(options(save.opt, add=TRUE))
        }
        knitr::knit(.RmdFile, paste(.filename, ".md", sep=""), quiet=TRUE)
        .html.file <- paste(.filename, ".html", sep="")
        markdown::markdownToHTML(paste(.filename, ".md", sep=""), .html.file)
        .html.file.location <- paste("file:///", normalizePath(.html.file), sep="")
        Message(paste(gettextRcmdr("HTML file written to:"), normalizePath(.html.file)), type="note")
        browseURL(.html.file.location)
    }
}

# the following functions to support knitr

beginRnwBlock <- function(){
    .rnw <- RnwWindow()
    last2 <- tclvalue(tkget(.rnw, "end -2 chars", "end"))
    if (last2 != "\n\n") tkinsert(.rnw, "end", "\n")
    tkinsert(.rnw, "end", "\n")
    tkinsert(.rnw, "end", "\\newpage\n")
    tkinsert(.rnw, "end", "<<>>=\n")
    if (getRcmdr("knitr.editor.open")){
        .knitr.editor <- knitrEditorWindow()
        last2 <- tclvalue(tkget(.knitr.editor, "end -2 chars", "end"))
        if (last2 != "\n\n") tkinsert(.knitr.editor, "end", "\n")
        tkinsert(.knitr.editor, "end", "\n")
        tkinsert(.knitr.editor, "end", "\\newpage\n")
        tkinsert(.knitr.editor, "end", "<<>>=\n")
    }
}

endRnwBlock <- function(){
    .rnw <- RnwWindow()
    rnw <- tclvalue(tkget(.rnw, "1.0", "end"))
    rnw <- paste(substring(rnw, 1, nchar(rnw) - 1), "@\n", sep="")
    rnw <- trimHangingEndRnwBlock(rnw)
    rmw <- trimTrailingNewLines(rnw)
    tkdelete(.rnw, "1.0", "end")
    tkinsert(.rnw, "end", rnw)
    tkyview.moveto(.rnw, 1)
    if (getRcmdr("knitr.editor.open")){
        .knitr.editor <- knitrEditorWindow()
        rnw <- tclvalue(tkget(.knitr.editor, "1.0", "end"))
        rnw <- paste(substring(rnw, 1, nchar(rnw) - 1), "@\n", sep="")
        rnw <- trimHangingEndRnwBlock(rnw)
        rmw <- trimTrailingNewLines(rnw)
        tkdelete(.knitr.editor, "1.0", "end")
        tkinsert(.knitr.editor, "end", rnw)
        tkyview.moveto(.knitr.editor, 1)
    }
}

removeNullRnwBlocks <- function(){
    .rnw <- RnwWindow()
    rnw <- tclvalue(tkget(.rnw, "1.0", "end"))
    rnw <- gsub("\n+$", "\n", rnw)
    rnw <- gsub("<<>>=\n$", "", rnw)
    rnw <- gsub("<<>>=\n@\n$", "", rnw)
    rnw <- gsub("\\\\newpage\n*$", "", rnw)
    rnw <- gsub("\\\\newpage\n*$", "", rnw)
    tkdelete(.rnw, "1.0", "end")
    tkinsert(.rnw, "end", rnw)
    tkyview.moveto(.rnw, 1)
    if (getRcmdr("knitr.editor.open")){
        .knitr.editor <- knitrEditorWindow()
        rnw <- tclvalue(tkget(.knitr.editor, "1.0", "end"))
        rnw <- gsub("\n+$", "\n", rnw)
        rnw <- gsub("<<>>=\n$", "", rnw)
        rnw <- gsub("<<>>=\n@\n$", "", rnw)
        rnw <- gsub("\\\\newpage\n*$", "", rnw)
        rnw <- gsub("\\\\newpage\n*$", "", rnw)
        tkdelete(.knitr.editor, "1.0", "end")
        tkinsert(.knitr.editor, "end", rnw)
        tkyview.moveto(.knitr.editor, 1)
    }
}

removeStrayRnwBlocks <- function(){
    .rnw <- RnwWindow()
    rnw <- tclvalue(tkget(.rnw, "1.0", "end"))
    rnw <- strsplit(rnw, "\\n")[[1]]
    starts <- grep("^<<.*>>=$", rnw)
    ends  <- grep("^@$", rnw)
    n.ends <- length(ends)
    j <- 1
    if (length(starts) > 1){
        for (i in (length(starts) - 1)){
            if (j > n.ends || ends[j] > starts[i + 1]) {
                rnw[starts[i]] <- ""
            }
            else {
                j <- j + 1
                next
            }
        }
    }
    else return()
    rnw <- paste(rnw, collapse="\n")
    tkdelete(.rnw, "1.0", "end")
    tkinsert(.rnw, "end", rnw)
    tkyview.moveto(.rnw, 1)
    if (getRcmdr("knitr.editor.open")){
        .knitr.editor <- knitrEditorWindow()
        rnw <- tclvalue(tkget(.knitr.editor, "1.0", "end"))
        rnw <- strsplit(rnw, "\\n")[[1]]
        starts <- grep("^<<.*>>=$", rnw)
        ends  <- grep("^@$", rnw)
        n.ends <- length(ends)
        j <- 1
        if (length(starts) > 1){
            for (i in (length(starts) - 1)){
                if (j > n.ends || ends[j] > starts[i + 1]) {
                    rnw[starts[i]] <- ""
                }
                else {
                    j <- j + 1
                    next
                }
            }
        }
        else return()
        rnw <- paste(rnw, collapse="\n")
        tkdelete(.knitr.editor, "1.0", "end")
        tkinsert(.knitr.editor, "end", rnw)
        tkyview.moveto(.knitr.editor, 1)
    }
}

enterKnitr <- function(command){
    .rnw <- RnwWindow()
    if (!getRcmdr("use.knitr")) return()
    command <- splitCmd(command)
    beginRnwBlock()
    tkinsert(.rnw, "end", paste(command, "\n", sep=""))
    tkyview.moveto(.rnw, 1)
    putRcmdr("knitr.output", TRUE)
    if (getRcmdr("knitr.editor.open")){
        .knitr.editor <- knitrEditorWindow()
        tkinsert(.knitr.editor, "end", paste(command, "\n", sep=""))
        tkyview.moveto(.knitr.editor, 1)
    }
    endRnwBlock()
    command
}

trimHangingEndRnwBlock <- function(string){
    loc.ats <- gregexpr("@\n", string)[[1]]
    n.ats <- length(loc.ats)
    if (n.ats > 1){
        substr <- substring(string, loc.ats[n.ats - 1], loc.ats[n.ats])
        if (!grepl("<<>>=", substr)){
            string <- cutstring(string, loc.ats[n.ats], loc.ats[n.ats] + 1)
        }
    }
    string
}

removeLastRnwBlock <- function(){
    .rnw <- RnwWindow()
    rnw <- tclvalue(tkget(.rnw, "1.0", "end"))
    start <- gregexpr("\\\\newpage\n<<>>=\n", rnw)
    if (start[[1]][1] > 0){
        start <- start[[1]]
        start <- start[length(start)]
        tail <- substring(rnw, start, nchar(rnw))
        end <- gregexpr("@\n", tail)
        end <- if (end[[1]][1] > 0) end[[1]][1] + 1 else nchar(tail)
        rnw <- cutstring(rnw, start, start + end)
        rnw <- trimTrailingNewLines(rnw)
        tkdelete(.rnw, "1.0", "end")
        tkinsert(.rnw, "end", rnw)
        tkyview.moveto(.rnw, 1)
    }
    if (getRcmdr("knitr.editor.open")){
        .knitr.editor <- knitrEditorWindow()
        rnw <- tclvalue(tkget(.knitr.editor, "1.0", "end"))
        start <- gregexpr("\\\\newpage\n<<>>=\n", rnw)
        if (start[[1]][1] > 0){
            start <- start[[1]]
            start <- start[length(start)]
            tail <- substring(rnw, start, nchar(rnw))
            end <- gregexpr("@\n", tail)
            end <- if (end[[1]][1] > 0) end[[1]][1] + 1 else nchar(tail)
            rnw <- cutstring(rnw, start, start + end)
            rnw <- trimTrailingNewLines(rnw)
            tkdelete(.knitr.editor, "1.0", "end")
            tkinsert(.knitr.editor, "end", rnw)
            tkyview.moveto(.knitr.editor, 1)
        }
    }
}

compileRnw <- function(){
    .RnwFile <- getRcmdr("RnwFileName")
    rnwDir <- dirname(.RnwFile)
    saveDir <- setwd(rnwDir)
    on.exit(setwd(saveDir))
    fig.files <- list.files("./figure")
    fig.files <- fig.files[grep("^unnamed-chunk-[0-9]*\\..*$", fig.files)]
    if (length(fig.files) != 0) {
        response <- tkmessageBox(message = gettextRcmdr("Delete previously created knitr\ngraphics files (recommended)?"),
            icon = "question", type = "okcancel", default = "ok")
        if (tclvalue(response) == "ok") unlink(paste("./figure/", fig.files, sep=""))
    }
    removeStrayRnwBlocks()
    lines <- tclvalue(tkget(RnwWindow(), "1.0", "end"))
    lines <- paste(lines, "\n\\end{document}\n")
    .filename <- sub("\\.Rnw$", "", trim.blanks(.RnwFile))
    writeLines(lines, .RnwFile)
    knitr::knit2pdf(.RnwFile)
    .pdf.file <- paste(.filename, ".pdf", sep="")
    .pdf.file.location <- paste("file:///", normalizePath(.pdf.file), sep="")
    browseURL(.pdf.file.location)
}


knitrP <- function(){
    getRcmdr("log.commands") && getRcmdr("use.knitr")
}

# editor for R Markdown and knitr documents

RcmdrEditor <- function(buffer, title="R Commander Editor", ok,
                        help=NULL, file.menu=NULL, edit.menu=NULL, context.menu=NULL, toolbar.buttons=NULL){
    
    if (getRcmdr("Markdown.editor.open") || getRcmdr("knitr.editor.open")){
        Message(gettextRcmdr("Only one instance of the R Commander script editor may be open at a time."), type="error")
        return(invisible(NULL))
    }
        
  contextMenu <- function(){
    contextMenu <- tkmenu(tkmenu(editor), tearoff=FALSE)
    if (!is.null(context.menu)){
      for (item in context.menu){
        tkadd(contextMenu, "command", label=gettextRcmdr(item$label), command=item$command)
      }
      tkadd(contextMenu, "separator")
    }
    tkadd(contextMenu, "command", label=gettextRcmdr("Cut"), command=onCut)
    tkadd(contextMenu, "command", label=gettextRcmdr("Copy"), command=onCopy)
    tkadd(contextMenu, "command", label=gettextRcmdr("Paste"), command=onPaste)
    tkadd(contextMenu, "command", label=gettextRcmdr("Delete"), command=onDelete)
    tkadd(contextMenu, "separator")
    tkadd(contextMenu, "command", label=gettextRcmdr("Find..."), command=onFind)
    tkadd(contextMenu, "command", label=gettextRcmdr("Select all"), command=onSelectAll)
    tkadd(contextMenu, "separator")
    tkadd(contextMenu, "command", label=gettextRcmdr("Undo"), command=onUndo)
    tkadd(contextMenu, "command", label=gettextRcmdr("Redo"), command=onRedo)
    tkadd(contextMenu, "separator")
    tkadd(contextMenu, "command", label=gettextRcmdr("Clear window"), command=onClear)
    tkpopup(contextMenu, tkwinfo("pointerx", editor), tkwinfo("pointery", editor))
  }
  onCopy <- function(){
    selection <- strsplit(tclvalue(tktag.ranges(editor, "sel")), " ")[[1]]
    if (is.na(selection[1])) return()
    text <- tclvalue(tkget(editor, selection[1], selection[2]))
    tkclipboard.clear()
    tkclipboard.append(text)
  }
  onDelete <- function(){
    selection <- strsplit(tclvalue(tktag.ranges(editor, "sel")), " ")[[1]]
    if (is.na(selection[1])) return()
    tkdelete(editor, selection[1], selection[2])
  }
  onCut <- function(){
    onCopy()
    onDelete()
  }
  onPaste <- function(){
    onDelete()
    text <- tclvalue(.Tcl("selection get -selection CLIPBOARD"))
    if (length(text) == 0) return()
    tkinsert(editor, "insert", text)
  }
  onFind <- function(){
    initializeDialog(title=gettextRcmdr("Find"))
    textFrame <- tkframe(top)
    textVar <- tclVar(getRcmdr("last.search"))
    textEntry <- ttkentry(textFrame, width="20", textvariable=textVar)
    checkBoxes(frame="optionsFrame", boxes=c("regexpr", "case"), initialValues=c("0", "1"),
               labels=gettextRcmdr(c("Regular-expression search", "Case sensitive")))
    radioButtons(name="direction", buttons=c("foward", "backward"), labels=gettextRcmdr(c("Forward", "Backward")),
                 values=c("-forward", "-backward"), title=gettextRcmdr("Search Direction"))
    onOK <- function(){
      text <- tclvalue(textVar)
      putRcmdr("last.search", text)
      if (text == ""){
        errorCondition(recall=onFind, message=gettextRcmdr("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.txt <- if (case) tksearch(editor, type, direction, "--", text, "insert", stop)
      else tksearch(editor, type, direction, "-nocase", "--", text, "insert", stop)
      where.txt <- tclvalue(where.txt)
      if (where.txt == "") {
        Message(message=gettextRcmdr("Text not found."),
                type="note")
        if (GrabFocus()) tkgrab.release(top)
        tkdestroy(top)
        tkfocus(CommanderWindow())
        return()
      }
      if (GrabFocus()) tkgrab.release(top)
      tkfocus(editor)
      tkmark.set(editor, "insert", where.txt)
      tksee(editor, where.txt)
      tkdestroy(top)
    }
    .exit <- function(){
      text <- tclvalue(textVar)
      putRcmdr("last.search", text)
      return("")
    }
    OKCancelHelp()
    tkgrid(labelRcmdr(textFrame, text=gettextRcmdr("Search for:")), textEntry, sticky="w")
    tkgrid(textFrame, sticky="w")
    tkgrid(optionsFrame, sticky="w")
    tkgrid(directionFrame, sticky="w")
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix(focus=textEntry)
  }
  onSelectAll <- function() {
    tktag.add(editor, "sel", "1.0", "end")
    tkfocus(editor)
  }
  onClear <- function(){
    onSelectAll()
    onDelete()
  }
  onUndo <- function(){
    tcl(editor, "edit", "undo")
  }
  onRedo <- function(){
    tcl(editor, "edit", "redo")
  }
  initializeDialog(title = gettextRcmdr(title), suppress.window.resize.buttons=FALSE)
  toolbarFrame <- tkframe(top) 
  cutButton <- buttonRcmdr(toolbarFrame, image="::image::cutIcon", command=onCut)
  copyButton <- buttonRcmdr(toolbarFrame, image="::image::copyIcon", command=onCopy)
  pasteButton <- buttonRcmdr(toolbarFrame, image="::image::pasteIcon", command=onPaste)
  deleteButton <- buttonRcmdr(toolbarFrame, image="::image::deleteIcon", command=onDelete)
  undoButton <- buttonRcmdr(toolbarFrame, image="::image::undoIcon", command=onUndo)
  redoButton <- buttonRcmdr(toolbarFrame, image="::image::redoIcon", command=onRedo)
  findButton <- buttonRcmdr(toolbarFrame, image="::image::findIcon", command=onFind)
  if (!is.null(toolbar.buttons)){
    for (i in 1:length(toolbar.buttons)){
      tool <- toolbar.buttons[[i]]
      assign(paste("var", i, sep=""), tclVar(gettextRcmdr(tool$label)))
      assign(paste("button", i, sep=""), buttonRcmdr(toolbarFrame, textvariable=eval(parse(text=paste("var", i, sep=""))), 
                                                     borderwidth="2", command=tool$command, image=tool$image, compound="left"))
    }
  }
  editorFrame <- tkframe(top)
  screenheight <- as.numeric(.Tcl(paste("winfo screenheight", top$ID)))
  char.size <- as.numeric(.Tcl(paste("font metrics", getRcmdr('logFont'))))[6]
  width <- as.numeric(tkcget(LogWindow(), "-width")) + 5
  height <- max(floor(screenheight/(2.5*char.size)), 25)   
  editor <- tktext(editorFrame, bg = "white", font = getRcmdr("logFont"), 
                   height = height, width = width, wrap = "none", undo=TRUE)
  if (title == "Edit R Markdown document") {
      putRcmdr("Markdown.editor.open", TRUE)
      putRcmdr("markdown.editor.toplevel.window", top)
  }
  if (title == "Edit knitr document") {
      putRcmdr("knitr.editor.open", TRUE)
      putRcmdr("knitr.editor.toplevel.window", top)
  }
  putRcmdr("editor.text", editor)
  editorXscroll <- ttkscrollbar(editorFrame, orient = "horizontal", 
                                command = function(...) tkxview(editor, ...))
  editorYscroll <- ttkscrollbar(editorFrame, command = function(...) tkyview(editor, 
                                                                             ...))
  tkconfigure(editor, xscrollcommand = function(...) tkset(editorXscroll, 
                                                           ...))
  tkconfigure(editor, yscrollcommand = function(...) tkset(editorYscroll, 
                                                           ...))
  tkinsert(editor, "1.0", buffer)
  onOK <- function(){
    if (title == "Edit R Markdown document") putRcmdr("Markdown.editor.open", FALSE)
    if (title == "Edit knitr document") putRcmdr("knitr.editor.open", FALSE)
    ok()
    closeDialog()
  }
  .exit <- function(){
    answer <- RcmdrTkmessageBox(gettextRcmdr("Discard edits?"), icon="question", type="yesno")
    if (as.character(answer) == "no") return("abort")
    else{
        if (title == "Edit R Markdown document") putRcmdr("Markdown.editor.open", FALSE)
        if (title == "Edit knitr document") putRcmdr("knitr.editor.open", FALSE)
        return("")
    }
    
  }
  OKCancelHelp(helpSubject = "ScriptEditor")
  editorMenu <- tkmenu(top)
  tkconfigure(top, menu = editorMenu)
  fileMenu <- tkmenu(editorMenu, tearoff=FALSE)
  if (!is.null(file.menu)){
    for (item in file.menu){
      tkadd(fileMenu, "command", label=gettextRcmdr(item$label), command=item$command)
    }
    tkadd(fileMenu, "separator")
  }
  tkadd(fileMenu, "command", label=gettextRcmdr("Exit editor saving edits"), command=onOK)
  tkadd(fileMenu, "command", label=gettextRcmdr("Cancel discarding edits"), command=onCancel)
  tkadd(editorMenu, "cascade", label=gettextRcmdr("File"), menu=fileMenu)
  editMenu <- tkmenu(editorMenu, tearoff=FALSE)
  if (!is.null(edit.menu)){
    for (item in edit.menu){
      tkadd(editMenu, "command", label=gettextRcmdr(item$label), command=item$command)
    }
    tkadd(editMenu, "separator")
  }
  tkadd(editMenu, "command", label=gettextRcmdr("Cut"), command=onCut)
  tkadd(editMenu, "command", label=gettextRcmdr("Copy"), command=onCopy)
  tkadd(editMenu, "command", label=gettextRcmdr("Paste"), command=onPaste)
  tkadd(editMenu, "command", label=gettextRcmdr("Delete"), command=onDelete)
  tkadd(editMenu, "separator")
  tkadd(editMenu, "command", label=gettextRcmdr("Find..."), command=onFind)
  tkadd(editMenu, "command", label=gettextRcmdr("Select all"), command=onSelectAll)
  tkadd(editMenu, "separator")
  tkadd(editMenu, "command", label=gettextRcmdr("Undo"), command=onUndo)
  tkadd(editMenu, "command", label=gettextRcmdr("Redo"), command=onRedo)
  tkadd(editMenu, "separator")
  tkadd(editMenu, "command", label=gettextRcmdr("Clear window"), command=onClear)
  tkadd(editorMenu, "cascade", label=gettextRcmdr("Edit"), menu=editMenu)
  helpMenu <- tkmenu(editorMenu, tearoff=FALSE)
  onEditorHelp <- function() print(help("ScriptEditor", package="Rcmdr"))
  tkadd(helpMenu, "command", label=gettextRcmdr("Editor help"), command=onEditorHelp)
  if (!is.null(help)){
    tkadd(helpMenu, "command", label=gettextRcmdr(help$label), command=help$command)
  }
  tkadd(editorMenu, "cascade", label=gettextRcmdr("Help"), menu=helpMenu)
  tkgrid(editor, editorYscroll, sticky = "nsew")
  tkgrid(editorXscroll)
  if (!is.null(toolbar.buttons)){
    for (i in 1:length(toolbar.buttons)){
      tkgrid(eval(parse(text=paste("button", i, sep=""))), sticky="w", row=0, column=i - 1,
             padx=c(3, 3), pady=c(0, 8))
    }
  }
  else i <- 0
  tkgrid(cutButton, sticky="w", row=0, column=i, padx=c(3, 3), pady=c(0, 8))
  tkgrid(copyButton, sticky="w", row=0, column=i + 1, padx=c(3, 3), pady=c(0, 8))
  tkgrid(pasteButton, sticky="w", row=0, column=i + 2, padx=c(3, 3), pady=c(0, 8))
  tkgrid(deleteButton, sticky="w", row=0, column=i + 3, padx=c(3, 3), pady=c(0, 8))
  tkgrid(undoButton, sticky="w", row=0, column=i + 4, padx=c(3, 3), pady=c(0, 8))
  tkgrid(redoButton, sticky="w", row=0, column=i + 5, padx=c(3, 3), pady=c(0, 8))
  tkgrid(findButton, sticky="w", row=0, column=i + 6, padx=c(3, 3), pady=c(0, 8))
  tkgrid(toolbarFrame, sticky="w")
  tk2tip(cutButton, gettextRcmdr("Cut"))
  tk2tip(copyButton, gettextRcmdr("Copy"))
  tk2tip(pasteButton, gettextRcmdr("Paste"))
  tk2tip(deleteButton, gettextRcmdr("Delete"))
  tk2tip(undoButton, gettextRcmdr("Undo"))
  tk2tip(redoButton, gettextRcmdr("Redo"))
  tk2tip(findButton, gettextRcmdr("Find"))
  tkgrid(editorFrame, sticky = "nsew")
  tkgrid.configure(editorXscroll, sticky = "ew")
  tkgrid.configure(editorYscroll, sticky = "ns")
  tkgrid.configure(editor, sticky = "nsew")
  tkgrid.configure(editorFrame, sticky = "nsew")
  tkgrid(buttonsFrame, sticky = "ew")
  tkbind(top, "<ButtonPress-3>", contextMenu)
  tkbind(top, "<Control-x>", onCut)
  tkbind(top, "<Control-X>", onCut)
  tkbind(top, "<Control-c>", onCopy)
  tkbind(top, "<Control-C>", onCopy)
  tkbind(top, "<Control-f>", onFind)
  tkbind(top, "<Control-F>", onFind)
  tkbind(top, "<F3>", onFind)
  tkbind(top, "<Control-a>", onSelectAll)
  tkbind(top, "<Control-A>", onSelectAll)
  tkbind(top, "<Control-w>", onRedo)
  tkbind(top, "<Control-W>", onRedo)
  tkbind(top, "<Alt-BackSpace>", onUndo)
  if (MacOSXP()){
    tkbind(top, "<Meta-x>", onCut)
    tkbind(top, "<Meta-X>", onCut)
    tkbind(top, "<Meta-c>", onCopy)
    tkbind(top, "<Meta-C>", onCopy)
    tkbind(top, "<Meta-v>", onPaste)
    tkbind(top, "<Meta-V>", onPaste)
    tkbind(top, "<Meta-f>", onFind)
    tkbind(top, "<Meta-F>", onFind)
    tkbind(top, "<Meta-a>", onSelectAll)
    tkbind(top, "<Meta-A>", onSelectAll)
    tkbind(top, "<Meta-w>", onRedo)
    tkbind(top, "<Meta-W>", onRedo)
    tkbind(top, "<Meta-z>", onUndo)
    tkbind(top, "<Meta-Z>", onUndo)
    tkbind(top, "<Shift-Meta-z>", onRedo)
    tkbind(top, "<Shift-Meta-Z>", onRedo)
  }
  tkwm.protocol(top, "WM_DELETE_WINDOW", onCancel)
  dialogSuffix(bindReturn = FALSE, resizable=TRUE, focus=editor, preventGrabFocus=TRUE)
  tkgrid.rowconfigure(top, 0, weight = 0)
  tkgrid.rowconfigure(top, 1, weight = 1)
  tkgrid.rowconfigure(top, 2, weight = 0)
  tkgrid.columnconfigure(top, 0, weight=1)
  tkgrid.rowconfigure(editorFrame, 1, weight=0)
  tkgrid.rowconfigure(editorFrame, 0, weight=1)
  tkgrid.columnconfigure(editorFrame, 0, weight=1)
  tkgrid.columnconfigure(editorFrame, 1, weight=0)
}

# the rgb2col function translates #RRGGBB colors to names if a named color exists or otherwise a "close" color (not exported)
#  uses code from r-help adapted from Kevin Wright

rgb2col <- local({
    all.names <- colors(distinct=TRUE)
    all.lab <- t(convertColor(t(col2rgb(all.names)), from = "sRGB", 
        to = "Lab", scale.in = 255))
    findNear <- function(x.lab) {
        sq.dist <- colSums((all.lab - x.lab)^2)
        rbind(all.names[which.min(sq.dist)], min(sq.dist))
    }
    function(cols.hex, near = 15) { # near = 2.3 is nominally the JND
        cols.lab <- t(convertColor(t(col2rgb(cols.hex)), from = "sRGB", 
            to = "Lab", scale.in = 255))
        cols.near <- apply(cols.lab, 2, findNear)
        ifelse(as.numeric(cols.near[2, ]) < near^2, cols.near[1, ], toupper(cols.hex))
    }
})

# the following function is for plug-ins that test for SciViews (which is no longer supported)

is.SciViews <- function() FALSE

# the following two functions from Milan Bouchet-Valat

setBusyCursor <- function() {
    .commander <- CommanderWindow()
    .menu <- tkcget(.commander, menu=NULL)
    .log <- LogWindow()
    .output <- OutputWindow()
    .messages <- MessagesWindow()
    
    tkconfigure(.commander, cursor="watch")
    tkconfigure(.menu, cursor="watch")
    tkconfigure(.log, cursor="watch")
    tkconfigure(.output, cursor="watch")
    tkconfigure(.messages, cursor="watch")
}

setIdleCursor <- function() {
    .commander <- CommanderWindow()
    .menu <- tkcget(.commander, menu=NULL)
    .log <- LogWindow()
    .output <- OutputWindow()
    .messages <- MessagesWindow()
    
    tkconfigure(.commander, cursor="")
    tkconfigure(.menu, cursor="")
    tkconfigure(.log, cursor="xterm")
    tkconfigure(.output, cursor="xterm")
    tkconfigure(.messages, cursor="xterm")
}

# Rcmdr data editor

editDataset <- function(data, dsname, ...){
  UseMethod("editDataset")
}

editDataset.character <- function(data, dsname, ...){
  if (missing(dsname)) dsname <- "Dataset"
  data <- data.frame(V1="NA")
  editDataset(data, dsname, ...)
}

editDataset.NULL <- function(data, dsname, ...){
  if (missing(dsname)) dsname <- "Dataset"
  data <- data.frame(V1="NA")
  editDataset(data, dsname, ...)
}

editDataset.data.frame <- function(data, dsname, ...){
    putRcmdr("dataset.modified", FALSE)
    # if (missing(data)){
    #     if (missing(dsname)) dsname <- "Dataset"
    #     data <- data.frame(V1="NA")
    # }
    # else {
    #     if (!inherits(data, "data.frame")) stop ("data argument must be a data frame")
    if (missing(dsname)) dsname <- deparse(substitute(data))
    # }
    if (getRcmdr("crisp.dialogs")) tclServiceMode(on=FALSE)
    top <- tktoplevel(borderwidth = 10)
    tkwm.title(top, paste(gettextRcmdr("Data Editor"), ": ", dsname, sep=""))
    location <- getRcmdr("open.dialog.here")
    pos <- 10 + commanderPosition()
    position <- if (any(pos < 0)) "-50+50" 
    else paste("+", paste(pos, collapse = "+"), sep = "")
    tkwm.geometry(top, position)
    tcl.array <- tclArray()
    nr <- nrow(data)
    nc <- ncol(data)
    data <- as.matrix(data)
    for (j in 1:nc){
        data.column <- data[, j]
        data.column[is.na(data.column)] <- "NA"
        if (any(grepl(" ", data.column))) data.column <- paste0("\"", data.column, "\"")
        data[, j] <- data.column
    }
    colnames <- colnames(data)
    rownames <- rownames(data)
    if (is.null(rownames)) rownames <- seq(length=nr)
    putRcmdr("data.dim", list(nr=nr, nc=nc, NR=nr, NC=nc))
    # NR, NC not decremented on row/column deletion
    #   to avoid possibly duplicate 
    #   auto-generated row/column names
    for (i in 1:nr) {
        tcl.array[[i + 1, 0]] <- i
        tcl.array[[i + 1, 1]] <- rownames[i]
    }
    for (j in 1:nc){
        tcl.array[[0, j + 1]] <- j
        tcl.array[[1, j + 1]] <- colnames[j]
    }
    tcl.array[[1, 1]] <- "rowname"
    for (i in 1:nr){
        for (j in 1:nc){
            .Tcl(paste("set ", tcl.array, "(", i + 1, ",", j + 1, ") ", data[i, j], sep = ""))
        }
    }
    tableFrame <- tkframe(top)
    data.table <- tk2table(tableFrame, rows=nr + 2, cols=nc + 2, 
                           titlerows=1, titlecols=1,
                           width=nc + 2, height=nr + 2, sparsearray=0,
                           cache=1, flashmode=1, autoclear=1, wrap=1, 
                           colstretchmode="all", rowstretchmode="all",
                           font=getRcmdr('logFont'), anchor="e", padx=6, 
                           resizeborders="both", drawmode="slow",
                           xscrollcommand=function(...) tkset(xscroll,...),
                           yscrollcommand=function(...) tkset(yscroll,...))
    tcl(data.table, "width", 0, max(max(nchar(as.character(nr))), 3))
    tcl(data.table, "width", 1, max(max(nchar(c(rownames, "rowname"))), 3))
    for (j in 1:nc){
        tcl(data.table, "width", j + 1, 
            max(max(nchar(c(colnames[j], data[, j]))), 8))
    }
    xscroll <- ttkscrollbar(tableFrame, orient="horizontal", 
                            command=function(...) tkxview(data.table,...))
    yscroll <- ttkscrollbar(tableFrame,
                            command=function(...) tkyview(data.table,...))
    deleteCell <- function() {
        result <- try(tkdelete(data.table, "active", "0", "end"), silent=TRUE)
        if (inherits(result, "try-error")) return()
        tkinsert(data.table, "active", "0", "NA")
    }
    copyCell <- function(){
        text <- try(tclvalue(tkget(data.table, "active")), silent=TRUE)
        if (inherits(text, "try-error")) return()
        tkclipboard.clear()
        tkclipboard.append(text)
    }
    pasteCell <- function(){
        text <- tclvalue(.Tcl("selection get -selection CLIPBOARD"))
        if (length(text) == 0) return()
        result <- try(tkdelete(data.table, "active", "0", "end"), silent=TRUE)
        if (inherits(result, "try-error")) return()
        tkinsert(data.table, "active", "0", text)
    }
    cutCell <- function(){
        copyCell()
        deleteCell()
    }
    addRow <- function(){
        dims <- getRcmdr("data.dim")
        nr <- dims$nr + 2
        nc <- dims$nc + 1
        NR <- dims$NR + 1
        NC <- dims$NC
        tkinsert(data.table, "row", nr + 1, 1)
        putRcmdr("data.dim", list(nr=nr - 1, nc=nc - 1, NR=NR, NC=NC))
        tcl.array[[nr, 0]] <- NR
        tcl.array[[nr, 1]] <- NR
        for (j in 1:nc) tcl.array[[nr, j + 1]] <- "NA"
        tkconfigure(data.table, width=nc + 1, height=nr + 1)
        tkactivate(data.table, paste0(nr, ",", 2))
        tcl(data.table, "yview", nr)
        tcl(data.table, "xview", 0)
    }
    addCol <- function(){
        dims <- getRcmdr("data.dim")
        nr <- dims$nr + 1
        nc <- dims$nc + 2
        NR <- dims$NR
        NC <- dims$NC + 1
        tkinsert(data.table, "cols", nc + 1, 1)
        putRcmdr("data.dim", list(nr=nr - 1, nc=nc - 1, NR=NR, NC=NC))
        tcl.array[[0, nc]] <- NC
        tcl.array[[1, nc]] <- paste("V", NC, sep="")
        for (i in 1:nr) tcl.array[[i + 1, nc]] <- "NA"
        tkconfigure(data.table, width=nc + 1, height=nr + 1)
        tkactivate(data.table, paste0(2, ",", nc))
        tcl(data.table, "xview", nc)
        tcl(data.table, "yview", 0)
    }
    deleteRow <- function(){
        result <- try(tkdelete(data.table , "rows",
                               tclvalue(tkindex(data.table, "active" ,"row")), 1),
                      silent=TRUE)
        if (inherits(result, "try-error")) return()
        dims <- getRcmdr("data.dim")
        nr <- dims$nr - 1
        nc <- dims$nc
        NR <- dims$NR
        NC <- dims$NC
        putRcmdr("data.dim", list(nr=nr, nc=nc, NR=NR, NC=NC))
    }
    deleteCol <- function(){
        result <- try(tkdelete(data.table , "cols",
                               tclvalue(tkindex(data.table, "active" ,"col")), 1),
                      silent=TRUE)
        if (inherits(result, "try-error")) return()
        dims <- getRcmdr("data.dim")
        nr <- dims$nr
        nc <- dims$nc - 1
        NR <- dims$NR
        NC <- dims$NC
        putRcmdr("data.dim", list(nr=nr, nc=nc, NR=NR, NC=NC))
    }
    onContextMenu <- function(){
        contextMenu <- tkmenu(tkmenu(data.table), tearoff=FALSE)
        tkadd(contextMenu, "command", label=gettextRcmdr("Delete current row"), 
              command=deleteRow)
        tkadd(contextMenu, "command", label=gettextRcmdr("Delete current column"),
              command=deleteCol)
        tkadd(contextMenu, "command", label=gettextRcmdr("Delete cell"), 
              command=deleteCell)
        tkadd(contextMenu, "command", label=gettextRcmdr("Cut cell"), 
              command=cutCell)
        tkadd(contextMenu, "command", label=gettextRcmdr("Copy cell"), 
              command=copyCell)
        tkadd(contextMenu, "command", label=gettextRcmdr("Paste cell"), 
              command=pasteCell)
        tkpopup(contextMenu, tkwinfo("pointerx", data.table), 
                tkwinfo("pointery", data.table))
    }
    onOK <- function(){
        closeDialog()
        dims <- getRcmdr("data.dim")
        nr <- dims$nr + 1
        nc <- dims$nc + 1
        data <- matrix("", nc + 1, nr)
        for (i in 1:nr){
            for (j in 1:nc){
                data[j, i] <- trim.blanks(tclvalue(tcl.array[[i, j]]))
                if (data[j, i] == "") data[j, i] <- "NA"
                else if (grepl('^".*"$', s <- data[j, i])) data[j, i] <- substr(s, 2, nchar(s) - 1)
                else if (grepl("^'.*'$", s <- data[j, i])) data[j, i] <- substr(s, 2, nchar(s) - 1)
                if (grepl(" |'|\"", data[j, i])) data[j, i] <- paste0("\"", data[j, i], "\"")
            }
            data[nc + 1, i] <- "\n"
        }
        data <- paste(data[-1], collapse=" ")
        Data <- read.table(textConnection(data), header=TRUE)
        gassign(dsname, Data)
        activeDataSet(dsname)
        putRcmdr("dataset.modified", TRUE)
    }
    onReturn <- function(){
        location <- try(as.numeric(unlist(strsplit(tclvalue(tkindex(data.table, "active")), ","))), 
                        silent=TRUE)
        if (inherits(location, "try-error")) return()
        text <- tclvalue(tcl.array[[location[1], location[2]]])
        on.exit(tcl.array[[location[1], location[2]]] <- sub("\n", "", text))
        addRow()
    }
    .exit <- function(){
        answer <- RcmdrTkmessageBox(gettextRcmdr("Discard edits?"), icon="question", type="yesno", default="no")
        if (as.character(answer) == "no") "abort" else ""
    }
    OKCancelHelp(helpSubject="editDataset")
    editorMenu <- tkmenu(top)
    tkconfigure(top, menu = editorMenu)
    fileMenu <- tkmenu(editorMenu, tearoff=FALSE)
    tkadd(fileMenu, "command", label=gettextRcmdr("Exit and save"), command=onOK)
    tkadd(fileMenu, "command", label=gettextRcmdr("Cancel"), command=onCancel)
    tkadd(editorMenu, "cascade", label=gettextRcmdr("File"), menu=fileMenu)   
    editMenu <- tkmenu(editorMenu, tearoff=FALSE)
    tkadd(editMenu, "command", label=gettextRcmdr("Delete current row"), 
          command=deleteRow)
    tkadd(editMenu, "command", label=gettextRcmdr("Delete current column"), 
          command=deleteCol)
    tkadd(editMenu, "command", label=gettextRcmdr("Add row"), command=addRow)
    tkadd(editMenu, "command", label=gettextRcmdr("Add column"), command=addCol)
    tkadd(editMenu, "command", label=gettextRcmdr("Cut cell"), command=cutCell)
    tkadd(editMenu, "command", label=gettextRcmdr("Copy cell"), command=copyCell)
    tkadd(editMenu, "command", label=gettextRcmdr("Paste cell"), 
          command=pasteCell)
    tkadd(editorMenu, "cascade", label=gettextRcmdr("Edit"), menu=editMenu)   
    helpMenu <- tkmenu(editorMenu, tearoff=FALSE)
    onEditorHelp <- function() print(help("editDataset"))
    tkadd(helpMenu, "command", label=gettextRcmdr("Editor help"), 
          command=onEditorHelp)
    tkadd(editorMenu, "cascade", label=gettextRcmdr("Help"), menu=helpMenu)    
    tkbind(data.table, "<Control-x>", cutCell) # FIXME!
    tkbind(data.table, "<Control-X>", cutCell) #  doesn't work -- source of error unclear
    tkbind(data.table, "<Control-c>", copyCell)
    tkbind(data.table, "<Control-C>", copyCell)
    tkbind(data.table, "<Control-v>", pasteCell)
    tkbind(data.table, "<Control-V>", pasteCell) 
    tkbind(data.table, "<ButtonPress-3>", onContextMenu)
    tkbind(data.table, "<Control-ButtonPress-1>", onContextMenu)
    tkbind(data.table, "<Double-Button-1>", deleteCell)
    if (MacOSXP()){
        tkbind(data.table, "<Meta-x>", cutCell) # FIXME!
        tkbind(data.table, "<Meta-X>", cutCell) #  doesn't work -- source of error unclear
        tkbind(data.table, "<Meta-c>", copyCell)
        tkbind(data.table, "<Meta-C>", copyCell)
        tkbind(data.table, "<Meta-v>", pasteCell)
        tkbind(data.table, "<Meta-V>", pasteCell) 
        tkbind(data.table, "<Meta-ButtonPress-1>", onContextMenu)
    }
    buttonsAddFrame <- tkframe(top)
    addRowButton <- ttkbutton(buttonsAddFrame, command=addRow, 
                              text=gettextRcmdr("Add row"))
    addColButton <- ttkbutton(buttonsAddFrame, command=addCol, 
                              text=gettextRcmdr("Add column"))
    tkgrid(addRowButton, addColButton, sticky="w")
    tkgrid(buttonsAddFrame, sticky="w")
    tkgrid(data.table, yscroll, sticky="news")
    tkgrid.configure(yscroll, sticky="ns")
    tkgrid(xscroll, sticky="ew")
    tkconfigure(data.table, variable=tcl.array, background="lightgray", 
                selectmode="extended")
    tktag.configure(data.table, "active", fg="black", bg="white")
    tktag.configure(data.table, "flash", fg="white", bg="gray")
    tcl(data.table, "tag", "col", "rownos", 0)
    tktag.configure(data.table, "rownos", anchor="e")  
    warn <- options(warn=-1)
    on.exit(warn)
    row.numbers <- !any(is.na(as.numeric(rownames)))
    tcl(data.table, "tag", "col", "rownames", 1)
    tktag.configure(data.table, "rownames", 
                    anchor=if (row.numbers) "e" else "w", bg="darkgray")  
    tcl(data.table, "tag", "row", "colnames", 1)
    tktag.configure(data.table, "colnames", bg="darkgray")  
    tkgrid(tableFrame, sticky="news")
    tkgrid(buttonsFrame, sticky="w")
    tkwm.protocol(top, "WM_DELETE_WINDOW", onCancel)
    dialogSuffix(resizable=TRUE)
    tkgrid.rowconfigure(top, 0, weight = 0)
    tkgrid.rowconfigure(top, 1, weight = 1)
    tkgrid.rowconfigure(top, 2, weight = 0)
    tkgrid.columnconfigure(top, 0, weight = 1)
    tkgrid.rowconfigure(tableFrame, 0, weight = 1)
    tkgrid.rowconfigure(tableFrame, 1, weight = 0)
    tkgrid.columnconfigure(tableFrame, 0, weight = 1)
    tkgrid.columnconfigure(tableFrame, 1, weight = 0)
    tkconfigure(data.table, selectmode = "extended", rowseparator = "\"\n\"", colseparator = "\"\t\"")
    tkconfigure(data.table, multiline = FALSE)
    tkbind(top, "<Key-Return>", onReturn)
    tkbind(top, "<Key-Tab>", addCol)
    tkwait.window(top)
}


# editDataset <- function(data, dsname){
#   putRcmdr("dataset.modified", FALSE)
#   if (missing(data)){
#     if (missing(dsname)) dsname <- "Dataset"
#     data <- data.frame(V1="NA")
#   }
#   else {
#     if (!inherits(data, "data.frame")) stop ("data argument must be a data frame")
#     if (missing(dsname)) dsname <- deparse(substitute(data))
#   }
#   if (getRcmdr("crisp.dialogs")) tclServiceMode(on=FALSE)
#   top <- tktoplevel(borderwidth = 10)
#   tkwm.title(top, paste(gettextRcmdr("Data Editor"), ": ", dsname, sep=""))
#   location <- getRcmdr("open.dialog.here")
#   pos <- 10 + commanderPosition()
#   position <- if (any(pos < 0)) "-50+50" 
#   else paste("+", paste(pos, collapse = "+"), sep = "")
#   tkwm.geometry(top, position)
#   #  tkwm.geometry(top, '-20+200')
#   tcl.array <- tclArray()
#   nr <- nrow(data)
#   nc <- ncol(data)
#   for (j in 1:nc){
#     data.column <- as.character(data[, j])
#     data.column[is.na(data.column)] <- "NA"
#     data[, j] <- data.column
#   }
#   colnames <- colnames(data)
#   rownames <- rownames(data)
#   putRcmdr("data.dim", list(nr=nr, nc=nc, NR=nr, NC=nc))
#   # NR, NC not decremented on row/column deletion
#   #   to avoid possibly duplicate 
#   #   auto-generated row/column names
#   for (i in 1:nr) {
#     tcl.array[[i + 1, 0]] <- i
#     tcl.array[[i + 1, 1]] <- rownames[i]
#   }
#   for (j in 1:nc){
#     tcl.array[[0, j + 1]] <- j
#     tcl.array[[1, j + 1]] <- colnames[j]
#   }
#   tcl.array[[1, 1]] <- "rowname"
#   for (i in 1:nr){
#     for (j in 1:nc){
#       tcl.array[[i + 1, j + 1]] <- data[i, j]
#     }
#   }
#   tableFrame <- tkframe(top)
#   data.table <- tk2table(tableFrame, rows=nr + 2, cols=nc + 2, 
#                          titlerows=1, titlecols=1,
#                          width=nc + 2, height=nr + 2, sparsearray=0,
#                          cache=1, flashmode=1, autoclear=1, wrap=1, 
#                          colstretchmode="all", rowstretchmode="all",
#                          font=getRcmdr('logFont'), anchor="e", padx=6, 
#                          resizeborders="both", drawmode="slow",
#                          xscrollcommand=function(...) tkset(xscroll,...),
#                          yscrollcommand=function(...) tkset(yscroll,...))
#   tcl(data.table, "width", 0, max(max(nchar(as.character(nr))), 3))
#   tcl(data.table, "width", 1, max(max(nchar(c(rownames, "rowname"))), 3))
#   for (j in 1:nc){
#     tcl(data.table, "width", j + 1, 
#         max(max(nchar(c(colnames[j], data[, j]))), 8))
#   }
#   xscroll <- ttkscrollbar(tableFrame, orient="horizontal", 
#                           command=function(...) tkxview(data.table,...))
#   yscroll <- ttkscrollbar(tableFrame,
#                           command=function(...) tkyview(data.table,...))
#   deleteCell <- function() {
#     result <- try(tkdelete(data.table, "active", "0", "end"), silent=TRUE)
#     if (inherits(result, "try-error")) return()
#     tkinsert(data.table, "active", "0", "NA")
#   }
#   copyCell <- function(){
#     text <- try(tclvalue(tkget(data.table, "active")), silent=TRUE)
#     if (inherits(text, "try-error")) return()
#     tkclipboard.clear()
#     tkclipboard.append(text)
#   }
#   pasteCell <- function(){
#     text <- tclvalue(.Tcl("selection get -selection CLIPBOARD"))
#     if (length(text) == 0) return()
#     result <- try(tkdelete(data.table, "active", "0", "end"), silent=TRUE)
#     if (inherits(result, "try-error")) return()
#     tkinsert(data.table, "active", "0", text)
#   }
#   cutCell <- function(){
#     copyCell()
#     deleteCell()
#   }
#   addRow <- function(){
#     dims <- getRcmdr("data.dim")
#     nr <- dims$nr + 2
#     nc <- dims$nc + 1
#     NR <- dims$NR + 1
#     NC <- dims$NC
#     tkinsert(data.table, "row", nr + 1, 1)
#     putRcmdr("data.dim", list(nr=nr - 1, nc=nc - 1, NR=NR, NC=NC))
#     tcl.array[[nr, 0]] <- NR
#     tcl.array[[nr, 1]] <- NR
#     for (j in 1:nc) tcl.array[[nr, j + 1]] <- "NA"
#     tkconfigure(data.table, width=nc + 1, height=nr + 1)
#     tkactivate(data.table, paste0(nr, ",", 2))
#     tcl(data.table, "yview", nr)
#     tcl(data.table, "xview", 0)
#   }
#   addCol <- function(){
#     dims <- getRcmdr("data.dim")
#     nr <- dims$nr + 1
#     nc <- dims$nc + 2
#     NR <- dims$NR
#     NC <- dims$NC + 1
#     tkinsert(data.table, "cols", nc + 1, 1)
#     putRcmdr("data.dim", list(nr=nr - 1, nc=nc - 1, NR=NR, NC=NC))
#     tcl.array[[0, nc]] <- NC
#     tcl.array[[1, nc]] <- paste("V", NC, sep="")
#     for (i in 1:nr) tcl.array[[i + 1, nc]] <- "NA"
#     tkconfigure(data.table, width=nc + 1, height=nr + 1)
#     tkactivate(data.table, paste0(2, ",", nc))
#     tcl(data.table, "xview", nc)
#     tcl(data.table, "yview", 0)
#   }
#   deleteRow <- function(){
#     result <- try(tkdelete(data.table , "rows",
#                            tclvalue(tkindex(data.table, "active" ,"row")), 1),
#                   silent=TRUE)
#     if (inherits(result, "try-error")) return()
#     dims <- getRcmdr("data.dim")
#     nr <- dims$nr - 1
#     nc <- dims$nc
#     NR <- dims$NR
#     NC <- dims$NC
#     putRcmdr("data.dim", list(nr=nr, nc=nc, NR=NR, NC=NC))
#   }
#   deleteCol <- function(){
#     result <- try(tkdelete(data.table , "cols",
#                            tclvalue(tkindex(data.table, "active" ,"col")), 1),
#                   silent=TRUE)
#     if (inherits(result, "try-error")) return()
#     dims <- getRcmdr("data.dim")
#     nr <- dims$nr
#     nc <- dims$nc - 1
#     NR <- dims$NR
#     NC <- dims$NC
#     putRcmdr("data.dim", list(nr=nr, nc=nc, NR=NR, NC=NC))
#   }
#   onContextMenu <- function(){
#     contextMenu <- tkmenu(tkmenu(data.table), tearoff=FALSE)
#     tkadd(contextMenu, "command", label=gettextRcmdr("Delete current row"), 
#           command=deleteRow)
#     tkadd(contextMenu, "command", label=gettextRcmdr("Delete current column"),
#           command=deleteCol)
#     tkadd(contextMenu, "command", label=gettextRcmdr("Delete cell"), 
#           command=deleteCell)
#     tkadd(contextMenu, "command", label=gettextRcmdr("Cut cell"), 
#           command=cutCell)
#     tkadd(contextMenu, "command", label=gettextRcmdr("Copy cell"), 
#           command=copyCell)
#     tkadd(contextMenu, "command", label=gettextRcmdr("Paste cell"), 
#           command=pasteCell)
#     tkpopup(contextMenu, tkwinfo("pointerx", data.table), 
#             tkwinfo("pointery", data.table))
#   }
#   onOK <- function(){
#     closeDialog()
#     dims <- getRcmdr("data.dim")
#     nr <- dims$nr + 1
#     nc <- dims$nc + 1
#     data <- matrix("", nc + 1, nr)
#     for (i in 1:nr){
#       for (j in 1:nc){
#         data[j, i] <- tclvalue(tcl.array[[i, j]])
#         if (trim.blanks(data[j, i]) == "") data[j, i] <- "NA"
#       }
#       data[nc + 1, i] <- "\n"
#     }
#     data <- paste(data[-1], collapse=" ")
#     Data <- read.table(textConnection(data), header=TRUE)
#     gassign(dsname, Data)
#     activeDataSet(dsname)
#     putRcmdr("dataset.modified", TRUE)
#   }
#   onReturn <- function(){
#     location <- try(as.numeric(unlist(strsplit(tclvalue(tkindex(data.table, "active")), ","))), 
#                     silent=TRUE)
#     if (inherits(location, "try-error")) return()
#     text <- tclvalue(tcl.array[[location[1], location[2]]])
#     on.exit(tcl.array[[location[1], location[2]]] <- sub("\n", "", text))
#     addRow()
#   }
#   .exit <- function(){
#     answer <- RcmdrTkmessageBox("Discard edits?", icon="question", type="yesno", default="no")
#     if (as.character(answer) == "no") "abort" else ""
#   }
#   OKCancelHelp(helpSubject="editDataset")
#   editorMenu <- tkmenu(top)
#   tkconfigure(top, menu = editorMenu)
#   fileMenu <- tkmenu(editorMenu, tearoff=FALSE)
#   tkadd(fileMenu, "command", label=gettextRcmdr("Exit and save"), command=onOK)
#   tkadd(fileMenu, "command", label=gettextRcmdr("Cancel"), command=onCancel)
#   tkadd(editorMenu, "cascade", label=gettextRcmdr("File"), menu=fileMenu)   
#   editMenu <- tkmenu(editorMenu, tearoff=FALSE)
#   tkadd(editMenu, "command", label=gettextRcmdr("Delete current row"), 
#         command=deleteRow)
#   tkadd(editMenu, "command", label=gettextRcmdr("Delete current column"), 
#         command=deleteCol)
#   tkadd(editMenu, "command", label=gettextRcmdr("Add row"), command=addRow)
#   tkadd(editMenu, "command", label=gettextRcmdr("Add column"), command=addCol)
#   tkadd(editMenu, "command", label=gettextRcmdr("Cut cell"), command=cutCell)
#   tkadd(editMenu, "command", label=gettextRcmdr("Copy cell"), command=copyCell)
#   tkadd(editMenu, "command", label=gettextRcmdr("Paste cell"), 
#         command=pasteCell)
#   tkadd(editorMenu, "cascade", label=gettextRcmdr("Edit"), menu=editMenu)   
#   helpMenu <- tkmenu(editorMenu, tearoff=FALSE)
#   onEditorHelp <- function() print(help("editDataset"))
#   tkadd(helpMenu, "command", label=gettextRcmdr("Editor help"), 
#         command=onEditorHelp)
#   tkadd(editorMenu, "cascade", label=gettextRcmdr("Help"), menu=helpMenu)    
#   tkbind(data.table, "<Control-x>", cutCell) # FIXME!
#   tkbind(data.table, "<Control-X>", cutCell) #  doesn't work -- source of error unclear
#   tkbind(data.table, "<Control-c>", copyCell)
#   tkbind(data.table, "<Control-C>", copyCell)
#   tkbind(data.table, "<Control-v>", pasteCell)
#   tkbind(data.table, "<Control-V>", pasteCell) 
#   tkbind(data.table, "<ButtonPress-3>", onContextMenu)
#   tkbind(data.table, "<Control-ButtonPress-1>", onContextMenu)
#   tkbind(data.table, "<Double-Button-1>", deleteCell)
#   if (MacOSXP()){
#     tkbind(data.table, "<Meta-x>", cutCell) # FIXME!
#     tkbind(data.table, "<Meta-X>", cutCell) #  doesn't work -- source of error unclear
#     tkbind(data.table, "<Meta-c>", copyCell)
#     tkbind(data.table, "<Meta-C>", copyCell)
#     tkbind(data.table, "<Meta-v>", pasteCell)
#     tkbind(data.table, "<Meta-V>", pasteCell) 
#     tkbind(data.table, "<Meta-ButtonPress-1>", onContextMenu)
#   }
#   buttonsAddFrame <- tkframe(top)
#   addRowButton <- ttkbutton(buttonsAddFrame, command=addRow, 
#                             text=gettextRcmdr("Add row"))
#   addColButton <- ttkbutton(buttonsAddFrame, command=addCol, 
#                             text=gettextRcmdr("Add column"))
#   tkgrid(addRowButton, addColButton, sticky="w")
#   tkgrid(buttonsAddFrame, sticky="w")
#   tkgrid(data.table, yscroll, sticky="news")
#   tkgrid.configure(yscroll, sticky="ns")
#   tkgrid(xscroll, sticky="ew")
#   tkconfigure(data.table, variable=tcl.array, background="lightgray", 
#               selectmode="extended")
#   tktag.configure(data.table, "active", fg="black", bg="white")
#   tktag.configure(data.table, "flash", fg="white", bg="gray")
#   tcl(data.table, "tag", "col", "rownos", 0)
#   tktag.configure(data.table, "rownos", anchor="e")  
#   warn <- options(warn=-1)
#   on.exit(warn)
#   row.numbers <- !any(is.na(as.numeric(rownames)))
#   tcl(data.table, "tag", "col", "rownames", 1)
#   tktag.configure(data.table, "rownames", 
#                   anchor=if (row.numbers) "e" else "w", bg="darkgray")  
#   tcl(data.table, "tag", "row", "colnames", 1)
#   tktag.configure(data.table, "colnames", bg="darkgray")  
#   tkgrid(tableFrame, sticky="news")
#   tkgrid(buttonsFrame, sticky="w")
#   tkwm.protocol(top, "WM_DELETE_WINDOW", onCancel)
#   dialogSuffix(resizable=TRUE)
#   tkgrid.rowconfigure(top, 0, weight = 0)
#   tkgrid.rowconfigure(top, 1, weight = 1)
#   tkgrid.rowconfigure(top, 2, weight = 0)
#   tkgrid.columnconfigure(top, 0, weight = 1)
#   tkgrid.rowconfigure(tableFrame, 0, weight = 1)
#   tkgrid.rowconfigure(tableFrame, 1, weight = 0)
#   tkgrid.columnconfigure(tableFrame, 0, weight = 1)
#   tkgrid.columnconfigure(tableFrame, 1, weight = 0)
#   tkconfigure(data.table, selectmode = "extended", rowseparator = "\"\n\"", colseparator = "\"\t\"")
#   tkconfigure(data.table, multiline = FALSE)
#   tkbind(top, "<Key-Return>", onReturn)
#   tkbind(top, "<Key-Tab>", addCol)
#   tkwait.window(top)
#}

# some Mac OS X related functions

RappP <- function() .Platform$GUI == "AQUA"

mavericksP <- function(){
  info <- Sys.info()
  info["sysname"] == "Darwin" && info["release"] >= "13.0.0"
}

appnap <- function(state=c("on", "off", "delete")){
  if (!mavericksP()) stop("requires OS X 10.9 or greater")
  save <- options(warn = -1)
  on.exit(options(save))
  if (missing(state)){
    res <- system("defaults read org.R-project.R NSAppSleepDisabled", 
                  intern=TRUE, ignore.stderr=TRUE)
    return(c("on", "off")[1 + (length(res) > 0 && res == "1")])
  }
  state <- match.arg(state)
  switch(state,
         delete = system("defaults delete org.R-project.R NSAppSleepDisabled", ignore.stderr=TRUE),
         off = system("defaults write org.R-project.R NSAppSleepDisabled -bool YES"),
         on = system("defaults write org.R-project.R NSAppSleepDisabled -bool NO")
  )
  return(state)
}

# replacement for standard tkmenu() to play better with ttk themes
#  courtesy of Philippe Grosjean

tkmenu <- function (parent, activebackground, activeforeground, ...) {
  if (!is.ttk()) 
    stop("Tcl/Tk >= 8.5 is required")
  w <- tkwidget(parent, "menu", ...)
  if (missing(activebackground)) activebackground <- tk2style("tk2button", "selectbackground")
  if (activebackground == "") activebackground = "darkblue" # Default value
  if (missing(activeforeground)) activeforeground <- tk2style("tk2button", "selectforeground")
  if (activeforeground == "") activeforeground = "white" # Default value
  tkconfigure(w, activebackground = activebackground, activeforeground = activeforeground)
  class(w) <- c("tk2menu", "tk2widget", class(w))
  return(w)
}

hasProgram <- function(program, version, prefix="--", line=1, compare=`>=`){
    # Args:
    #   program: quoted name of program
    #   version: quoted version number (numerals . -)
    #   prefix:  for version switch
    #   line:    output line containing version number
    #   compare: comparison operator for version
    # Example: hasProgram("pandoc", version="1.12")
    path <- Sys.which(program)
    present <-  path != ""
    if (missing(version) || !present) return(as.vector(present))
    result <- try(system2(path, args=paste(prefix, "version", sep=""), stderr=TRUE, stdout=TRUE),
        silent=TRUE)
    if (inherits(result, "try-error")){
        warning("could not execute '", path, " --version'")
        return(FALSE)
    }
    result <- result[line]
    match <- regexpr("((?:(\\d+)[\\.-])?)*(\\*|\\d+)", result)
    if (match == -1) {
        warning("could not locate version number in\n", result)
        return(FALSE)
    }
    result <- substr(result, match, match + attr(match, "match.length") - 1)
    compare(result, version)
}

RcmdrCapabilities <- function(check=list(c("pdflatex"), c("pandoc", version="1.12.3")),
                              checkTkTable=TRUE){
    result <- vector(length(check), mode="list")
    names(result) <- sapply(check, function(x) x[1])
    for (i in 1:length(check)){
        result[[i]] <- do.call(hasProgram, as.list(check[[i]]))
    }
    if (checkTkTable){
      result$tktable <- inherits(tclRequire("Tktable", warn = FALSE), "tclObj")
    }
    result
}

browsePDF <- function(file) {
    if (WindowsP()) shell.exec(file)
    else if (MacOSXP()) system(paste("open -a Preview", shQuote(file)))
    else system(paste(shQuote(getOption("pdfviewer")), shQuote(file)), wait=FALSE)
}

# function to insure that "levels" of character variables are returned

levels.character <- function(x) sort(unique(x))

# the following macro is used to apply Rcmdr options with specified defaults
#   if global == TRUE, store option

setOption <- defmacro(option, default, global=TRUE, expr= {
    opt <- if (is.null(current[option][[1]])) default else current[option][[1]]
    if (global) putRcmdr(option, opt)
    opt
})

# the following function determines capabilities for Models menu items

modelCapability <- function(capability){  
  modelCapabilities <- getRcmdr("modelCapabilities")
  model <- ActiveModel()
  if (is.null(model)) return(FALSE)
  class <- class(get(model, envir=.GlobalEnv))[1]
  result <- modelCapabilities[class, capability]
  if (is.null(result)) {
    warning(paste(gettextRcmdr("no such model capability:"), capability,
                  "\nreport problem to plug-in package author"))
    return(FALSE)
  }
  if (is.na(result)) result <- modelCapabilities["default", capability]
  if (is.na(result)) result <- FALSE
  if (!is.logical(result)) stop(gettextRcmdr("non-logical value in model capabilities table"))
  result
}

# work around for bug in Tk getSaveFile

# removeRedundantExtension <- function(file, exts){
#   for (ext in exts){
#     file <- sub(paste0(".", ext, ".", ext, "$"), paste0(".", ext), file)
#   }
#   file
# }

removeRedundantExtension <- function(file){
  find.ext <- regexpr("\\.(?:.(?!\\.))+$", file, perl=TRUE)
  if (find.ext == -1) return(file)
  ext <- substring(file, find.ext, find.ext + attr(find.ext, "match.length"))
  file <- sub(paste0(ext, ext, "$"), ext, file)
  file
}

# functions to support mixed models

anova.lmerMod <- function(object, ...) NextMethod()

Anova.lmerMod <- function(mod, ...) NextMethod()

linearHypothesis.lmerMod <- function(model, ...) NextMethod()

coef.lmerMod <- function(object, ...) fixef(object, ...)

anova.glmerMod <- function(object, ...) NextMethod()

Anova.glmerMod <- function(mod, ...) NextMethod()

linearHypothesis.glmerMod <- function(model, ...) NextMethod()

coef.glmerMod <- function(object, ...) fixef(object, ...)

plot.lmerMod <- function(x, ...) NextMethod()

plot.glmerMod <- function(x, ...) NextMethod()

validColumns <- function(dataset){
  valid.classes <- getRcmdr("valid.classes") 
  nc <- ncol(dataset)
  valid <- logical(nc)
  for (i in 1:nc){
    valid[i] <- is.numeric(dataset[[i]]) || any(sapply(valid.classes, function(class) inherits(dataset[[i]], class)))
  }
  if (any(!valid)){
    message <- if (sum(!valid) > 1){
      paste0(gettextRcmdr("The following variables are not valid for use in the R Commander and will be omitted:"), "\n",
            paste(colnames(dataset)[!valid], collapse=", "))
    } else {
      paste0(gettextRcmdr("The following variable is not valid for use in the R Commander and will be omitted:"), "\n",
            colnames(dataset)[!valid])
    }
    Message(message=message, type="warning")
  }
  valid
}

# add support for discrete numeric variables

listDiscreteNumeric <- function(dataSet=ActiveDataSet()) {
  if(missing(dataSet)) {
    DiscreteNumeric()
  }
  else {
    threshold <- getRcmdr("discreteness.threshold")
    if (threshold <= 0){
      n <- getRcmdr("nrow")
      if (is.null(n)) n <- nrow(get(dataSet, envir=.GlobalEnv))
      threshold <- min(round(2*sqrt(n)), round(10*log10(n)), 100)
    }
    variables <- listNumeric()
    if (length(variables) == 0) return(NULL)
    variables[sapply(variables, function(.x)
      length(unique(eval(parse(text=.x), envir=get(dataSet, envir=.GlobalEnv)))) <= threshold)]
  }
}

DiscreteNumeric <- function(names){
  if (missing(names)) getRcmdr("discrete.numeric")
  else putRcmdr("discrete.numeric", names)
}

discreteNumericP <- function(n=1) activeDataSetP() && length(listDiscreteNumeric()) >= n

dichotomousResponseLabel <- defmacro(frame=top, responseBox=xBox, columnspan=1, initialText=NULL,
                        expr={
                          initial.label <- if (exists("dialog.values")) dialog.values$initial.responseLabel else NULL
                          if  (is.null(initial.label)) {
                            response <- getSelection(responseBox)
                            initial.label <- if (length(response) == 0) NULL 
                            else {
                              levels <- eval(parse(text = paste("levels(", ActiveDataSet(), 
                                                                "$", response, ")", sep = "")))
                              levels[1]
                            }
                          }
                          responseFrame <- tkframe(frame)
                          .responseLabel <- if (!is.null(initialText)) initialText 
                          else if (is.null(initial.label)) gettextRcmdr("<No response selected>") 
                          else initial.label
                          responseLabel <- labelRcmdr(responseFrame, text=.responseLabel)
                          tkgrid(labelRcmdr(responseFrame, text=paste0(gettextRcmdr("Proportion"), " = "), fg=getRcmdr("title.color"), font="RcmdrTitleFont"), responseLabel, sticky="w")
                          tkgrid(responseFrame, sticky="w", columnspan=columnspan)
                          onSelect <- function(){
                            response <- getSelection(responseBox)
                            if (length(response) == 0) {
                              .responseLabel <<- gettextRcmdr("<No response selected>") 
                            }
                            else {
                              levels <- eval(parse(text=paste("levels(", ActiveDataSet(), "$", response, ")", sep="")))
                              .responseLabel <<- levels[1]
                            }
                            tkconfigure(responseLabel, text=.responseLabel)
                          }
                          tkbind(responseBox$listbox, "<ButtonRelease-1>", onSelect)
                        })

convertStrings2Factors <- function(){
  .activeDataSet <- activeDataSet() 
  command <- paste0(.activeDataSet, ' <- strings2factors(', .activeDataSet, ')')
  doItAndPrint(command)
  activeDataSet(.activeDataSet)
}

# functions for predictors and coefficients

Predictors <- function(type=c("all", "numeric", "factor")){
  if (is.null(ActiveModel())) return(NULL)
  type <- match.arg(type)
  predictors <- all.vars(formula(get(activeModel(), envir=.GlobalEnv))[[3]])
  if (type == "all") return(predictors)
  else if (type == "numeric") return(intersect(Numeric(), predictors))
  else if (type == "factor") return(intersect(Factors(), predictors))
}


PredictorsP <- function(n=1, type=c("all", "numeric", "factor")){
  type <- match.arg(type)
  length(Predictors(type=type)) >= n
}

Coefficients <- function(includeIntercept=FALSE){
  if (is.null(ActiveModel())) return(NULL)
  coefs <- names(coef(get(activeModel(), envir=.GlobalEnv)))
  coefs[coefs != "(Intercept)"]
}

CoefficientsP <- function(n=1, includeIntercept=FALSE){
  length(Coefficients(includeIntercept)) >= n
}

# the following function isn't exported

getUserName <- function(){
  if (MacOSXP()) {
    name <- try(system("id -F", intern=TRUE, ignore.stderr=TRUE),
                silent=TRUE)
    if (inherits(name, "try-error")) name <- Sys.info()["user"]
    if (name == "unknown") name <- "Your Name"
    return(name)
  } else if (WindowsP()){
    name <- Sys.info()["user"]
    if (name == "unknown") name <- "Your Name"
    return(name)
  } else {
    name <- try(system("finger $(whoami)", intern=TRUE, ignore.stderr=TRUE),
                silent=TRUE)
    if (!inherits(name, "try-error")){
      name <- name[grepl("^Login:", name)]
      return(sub("^.*Name: ", "", name))
    } else {
      name <- Sys.info()["user"]
      if (name == "unknown") name <- "Your Name"
      return(name)
    }
  }
}

# to assist implementation of case deletion/retention

getCases <- function(cases, remove=TRUE){
  rows <- Rows <- paste("c(", gsub(" +", ", ", cases), ")", sep="")
  cases.rows <- try(eval(parse(text=Rows)), silent=TRUE)
  if (inherits(cases.rows, "try-error")){
    rows <- Rows <- paste("c('", gsub(" +", "', '", cases), "')", sep="")
    cases.rows <- try(eval(parse(text=Rows)), silent=TRUE)
    if (inherits(cases.rows, "try-error")){
      error <- cases.rows
      class(error) <- c(class(error), "cases-error")
      return(error)
    }
  }
  if (remove) {
    Rows <- if (is.numeric(cases.rows)) paste("-", Rows, sep="") 
    else paste("!(rownames(", ActiveDataSet(), ") %in% ", Rows, ")", sep="")
  }
  else if (is.character(cases.rows)) Rows <- paste("rownames(", ActiveDataSet(), ") %in% ", Rows, sep="")
  if (is.numeric(cases.rows)){
    n <- eval(parse(text=paste0("nrow(", ActiveDataSet(), ")")))
    if (any(which.bad <- !cases.rows %in% 1:n)){
      error <- paste(gettextRcmdr("bad row numbers:"), 
                     paste(as.character(cases.rows[which.bad]), collapse=", "))
      class(error) <- c(class(error), "cases-error")
      return(error)
    }
  } else {
    if (any(which.bad <- eval(parse(text=paste("!", rows, "%in% rownames(", ActiveDataSet(), ")", sep=""))))){
      error <- paste(gettextRcmdr("bad row names:"), 
                     paste(cases.rows[which.bad], collapse=", "))
      class(error) <- c(class(error), "cases-error")
      return(error)          
    }
  }
  Rows
}

insertRmdSection <- function(text){
  if (!(getRcmdr("use.markdown") && getRcmdr("command.sections"))) return()
#  if (getRcmdr("translate.rmd.headers")) text <- gettextRcmdr(text)
  .rmd <- RmdWindow()
  rmd <- tclvalue(tkget(.rmd, "1.0", "end"))
  rmd <- strsplit(rmd, "\n")
  where <- grep("...\\{r", rmd[[1]])
  where <- rev(where)[1]
  where <- paste0(where, ".0")
  tkinsert(.rmd, where, paste0("\n", getRcmdr("section.level"), " ", text, "\n"))
  if (getRcmdr("Markdown.editor.open")){
    .markdown.editor <- MarkdownEditorWindow()
    rmd <- tclvalue(tkget(.markdown.editor, "1.0", "end"))
    rmd <- strsplit(rmd, "\n")
    where <- grep("...\\{r", rmd[[1]])
    where <- rev(where)[1]
    where <- paste0(where, ".0")
    tkinsert(.markdown.editor, where, paste0("\n", getRcmdr("section.level"), " ", text, "\n"))
    }
}

# the following function isn't exported and is currently
# only used for managing RMarkdown output

applyDefaultValues <- function(given, defaults){
  if (isTRUE(given)) return(defaults)
  names <- names(given)
  if (any(which <- !names %in% names(defaults))) {
    stop("bad names: ", names[which])
  }
  for (name in names){
    defaults[[name]] <- given[[name]]
  }
  defaults
}

gettextRmdHeader <- function(text){
  if (getRcmdr("translate.rmd.headers")) text <- gettextRcmdr(text)
  text
}

Try the Rcmdr package in your browser

Any scripts or data that you put into this service are public.

Rcmdr documentation built on Sept. 28, 2023, 5:08 p.m.