R/model-menu.R

In Rcmdr2: R Commander

# Model menu dialogs

# last modified 2013-04-24 by J. Fox

selectActiveModel <- function(){
	models <- listAllModels()
	.activeModel <- ActiveModel()
	if ((length(models) == 1) && !is.null(.activeModel)) {
		Message(message=gettextRcmdr("There is only one model in memory."),
				type="warning")
		tkfocus(CommanderWindow())
		return()
	}
	if (length(models) == 0){
		Message(message=gettextRcmdr("There are no models from which to choose."),
				type="error")
		tkfocus(CommanderWindow())
		return()
	}
	initializeDialog(title=gettextRcmdr("Select Model"))
	.activeDataSet <- ActiveDataSet()
	initial <- if (is.null(.activeModel)) NULL else which(.activeModel == models) - 1
	modelsBox <- variableListBox(top, models, title=gettextRcmdr("Models (pick one)"), 
			initialSelection=initial)
	onOK <- function(){
		model <- getSelection(modelsBox)
		closeDialog()
		if (length(model) == 0) {
			tkfocus(CommanderWindow())
			return()
		}
		dataSet <- as.character(get(model)$call$data)
		if (length(dataSet) == 0){
			errorCondition(message=gettextRcmdr("There is no dataset associated with this model."))
			return()
		}
		dataSets <- listDataSets()
		if (!is.element(dataSet, dataSets)){
			errorCondition(message=sprintf(gettextRcmdr("The dataset associated with this model, %s, is not in memory."), dataSet))
			return()
		}
		if (is.null(.activeDataSet) || (dataSet != .activeDataSet)) activeDataSet(dataSet)
		putRcmdr("modelWithSubset", "subset" %in% names(get(model)$call))
		activeModel(model)
		tkfocus(CommanderWindow())
	}
	OKCancelHelp()
	nameFrame <- tkframe(top)
	tkgrid(labelRcmdr(nameFrame, fg=getRcmdr("title.color"), text=gettextRcmdr("Current Model: ")), 
			labelRcmdr(nameFrame, text=tclvalue(getRcmdr("modelName"))), sticky="w")
	tkgrid(nameFrame, sticky="w", columnspan="2")
	tkgrid(getFrame(modelsBox), columnspan="2", sticky="w")
	tkgrid(buttonsFrame, columnspan=2, sticky="w")
	dialogSuffix(rows=3, columns=2)
}

summarizeModel <- function(){
	.activeModel <- ActiveModel()
	if (is.null(.activeModel) || !checkMethod("summary", .activeModel)) return()
	doItAndPrint(paste("summary(", .activeModel, ", cor=FALSE)", sep=""))
}

plotModel <- function(){
	.activeModel <- ActiveModel()
	if (is.null(.activeModel) || !checkMethod("plot", .activeModel)) return()
	command <- "oldpar <- par(oma=c(0,0,3,0), mfrow=c(2,2))"
	justDoIt(command)
	logger(command)
	doItAndPrint(paste("plot(", .activeModel, ")", sep=""))
	command <- "par(oldpar)"
	justDoIt(command)
	logger(command)
}

CRPlots <- function(){
    Library("car")
    .activeModel <- ActiveModel()
    if (is.null(.activeModel) || !checkMethod("crPlot", .activeModel)) return()
    
    defaults <- list(initial.span=50)
    dialog.values <- getDialog("CRPlots", defaults)
    initializeDialog(title = gettextRcmdr("Component+Residual Plots"))
    sliderValue <- tclVar(dialog.values$initial.span)
    sliderFrame <- tkframe(top)
    slider <- tkscale(sliderFrame, from = 5, to = 100, showvalue = TRUE, 
        variable = sliderValue, resolution = 5, orient = "horizontal")
    onOK <- function(){
        span <- as.numeric(tclvalue(sliderValue))
        closeDialog()
        putDialog ("CRPlots", list(initial.span=span))
        doItAndPrint(paste("crPlots(", .activeModel, ", span=", span/100, ")", sep=""))
        activateMenus()
        tkfocus(CommanderWindow())
    }
    OKCancelHelp(helpSubject = "crPlots", reset = "CRPlots")
    tkgrid(labelRcmdr(sliderFrame, text=gettextRcmdr("Span for smooth")), slider, sticky="sw")
    tkgrid(sliderFrame, sticky="w")
    tkgrid(buttonsFrame, sticky="w")
    dialogSuffix(rows=2, columns=1)
}

AVPlots <- function () {
    Library("car")
    .activeModel <- ActiveModel()
    if (is.null(.activeModel) || !checkMethod("avPlot", .activeModel)) 
        return()
    defaults <- list (initial.identify = "auto", initial.id.n="2")
    dialog.values <- getDialog ("AVPlots", defaults)
    initializeDialog(title = gettextRcmdr("Added-Variable Plots"))
    identifyPointsFrame <- tkframe(top)
    radioButtons(identifyPointsFrame, name = "identify", buttons = c("auto", "mouse", 
        "not"), labels = gettextRcmdr(c("Automatically", 
            "Interactively with mouse", "Do not identify")), title = gettextRcmdr("Identify Points"), 
        initialValue = dialog.values$initial.identify)    
    id.n.Var <- tclVar(dialog.values$initial.id.n) 
    npointsSpinner <- tkspinbox(identifyPointsFrame, from=1, to=10, width=2, textvariable=id.n.Var)      
    onOK <- function() {
        id.n <- tclvalue(id.n.Var)
        identify <- tclvalue(identifyVariable)
        method <- if (identify == "mouse") "identify" else "mahal"
        id.n.use <- if (identify == "not") 0 else id.n   
        closeDialog()
        if (is.na(suppressWarnings(as.numeric(id.n))) || round(as.numeric(id.n)) != as.numeric(id.n)){
            errorCondition(recall = AVPlots, message = gettextRcmdr("number of points to identify must be an integer"))
            return()
        }
        putDialog ("AVPlots", list (initial.identify = identify, initial.id.n=id.n))
        if (identify == "mouse") {
            RcmdrTkmessageBox(title = "Identify Points", message = paste(gettextRcmdr("Use left mouse button to identify points,\n"), 
                gettextRcmdr(if (MacOSXP()) 
                    "esc key to exit."
                    else "right button to exit."), sep = ""), icon = "info", 
                type = "ok")
        }
        command <- paste("avPlots(", .activeModel, ', id.method="', method, '", id.n=', id.n.use,  ")", sep = "")
        if (identify == "mouse") command <- suppressMarkdown(command)
        doItAndPrint(command)
        activateMenus()
        tkfocus(CommanderWindow())
    }
    OKCancelHelp(helpSubject = "avPlots", reset = "AVPlots")
    tkgrid(identifyFrame, sticky="w")
    tkgrid(labelRcmdr(identifyPointsFrame, text=gettextRcmdr("Number of points to identify  ")), npointsSpinner, sticky="w")
    tkgrid(identifyPointsFrame, sticky="w")
    tkgrid(buttonsFrame, sticky = "w")
    dialogSuffix(rows = 2, columns = 1)
}

InfluencePlot <- function () {
    Library("car")
    .activeModel <- ActiveModel()
    if (is.null(.activeModel) || !checkMethod("influencePlot", .activeModel)) 
        return()
    defaults <- list (initial.identify = "auto", initial.id.n="2")
    dialog.values <- getDialog ("InfluencePlot", defaults)
    initializeDialog(title = gettextRcmdr("Influence Plot"))
    identifyPointsFrame <- tkframe(top)
    radioButtons(identifyPointsFrame, name = "identify", buttons = c("auto", "mouse"), labels = gettextRcmdr(c("Automatically", 
        "Interactively with mouse")), title = gettextRcmdr("Identify Points"), 
        initialValue = dialog.values$initial.identify)    
    id.n.Var <- tclVar(dialog.values$initial.id.n) 
    npointsSpinner <- tkspinbox(identifyPointsFrame, from=1, to=10, width=2, textvariable=id.n.Var)      
    onOK <- function() {
        id.n <- tclvalue(id.n.Var)
        identify <- tclvalue(identifyVariable)
        method <- if (identify == "mouse") "identify" else "noteworthy"
        closeDialog()
        if (is.na(suppressWarnings(as.numeric(id.n))) || round(as.numeric(id.n)) != as.numeric(id.n)){
            errorCondition(recall = InfluencePlot, message = gettextRcmdr("number of points to identify must be an integer"))
            return()
        }
        putDialog ("InfluencePlot", list (initial.identify = identify, initial.id.n=id.n))
        if (identify == "mouse") {
            RcmdrTkmessageBox(title = "Identify Points", message = paste(gettextRcmdr("Use left mouse button to identify points,\n"), 
                gettextRcmdr(if (MacOSXP()) 
                    "esc key to exit."
                    else "right button to exit."), sep = ""), icon = "info", 
                type = "ok")
        }
        command <- paste("influencePlot(", .activeModel, ', id.method="', method, '", id.n=', id.n,  ")", sep = "")
        if (identify == "mouse") command <- suppressMarkdown(command)
        doItAndPrint(command)
        activateMenus()
        tkfocus(CommanderWindow())
    }
    OKCancelHelp(helpSubject = "influencePlot", reset = "InfluencePlot")
    tkgrid(identifyFrame, sticky="w")
    tkgrid(labelRcmdr(identifyPointsFrame, text=gettextRcmdr("Number of points to identify  ")), npointsSpinner, sticky="w")
    tkgrid(identifyPointsFrame, sticky="w")
    tkgrid(buttonsFrame, sticky = "w")
    dialogSuffix(rows = 2, columns = 1)
}

anovaTable <- function () {
	Library("car")
	.activeModel <- ActiveModel()
	if (is.null(.activeModel)) 
		return()
	defaults <- list (initial.type = "II")
	dialog.values <- getDialog ("anovaTable", defaults)
	initializeDialog(title = gettextRcmdr("ANOVA Table"))
	radioButtons(name = "type", buttons = c("I", "II", "III"), 
			values = c("I", "II", "III"), labels = gettextRcmdr(c("Sequential (\"Type I\")", 
							"Partial, obeying marginality (\"Type II\")", "Partial, ignoring marginality (\"Type III\")")), 
			title = gettextRcmdr("Type of Tests"), initialValue = dialog.values$initial.type)
	onOK <- function() {
		type <- as.character(tclvalue(typeVariable))
		putDialog ("anovaTable", list (initial.type = type))
		closeDialog()
		if (is.glm <- glmP()) {
			family <- eval(parse(text = paste(.activeModel, "$family$family", 
									sep = "")))
		}
		if (type == "I") {
			if (!checkMethod("anova", .activeModel)) {
				errorCondition(message = gettextRcmdr("There is no appropriate anova method for a model of this class."))
				return()
			}
			if (is.glm) {
				test <- if (family %in% c("binomial", "poisson")) 
							"Chisq"
						else "F"
				doItAndPrint(paste("anova(", .activeModel, ", test=\"", 
								test, "\")", sep = ""))
			}
			else doItAndPrint(paste("anova(", .activeModel, ")", 
								sep = ""))
		}
		else {
			if (!checkMethod("Anova", .activeModel)) {
				errorCondition(message = gettextRcmdr("There is no appropriate Anova method for a model of this class."))
				return()
			}
			if (is.glm) {
				test <- if (family %in% c("binomial", "poisson")) 
							"LR"
						else "F"
				doItAndPrint(paste("Anova(", .activeModel, ", type=\"", 
								type, "\", test=\"", test, "\")", sep = ""))
			}
			else doItAndPrint(paste("Anova(", .activeModel, ", type=\"", 
								type, "\")", sep = ""))
			if (type == "III") 
				Message(message = gettextRcmdr("Type III tests require careful attention to contrast coding."), 
						type = "warning")
		}
	}
	OKCancelHelp(helpSubject = "Anova", reset = "anovaTable")
	tkgrid(typeFrame, sticky = "w")
	tkgrid(buttonsFrame, sticky = "w")
	dialogSuffix(rows = 2, columns = 1)
}

VIF <- function(){
	Library("car")
	.activeModel <- ActiveModel()
	if (is.null(.activeModel) || !checkMethod("vif", .activeModel)) return()
	doItAndPrint(paste("vif(", .activeModel, ")", sep=""))
}

effectPlots <- function(){
	Library("effects")
	.activeModel <- ActiveModel()
	if (is.null(.activeModel) || !checkMethod("effect", .activeModel)) return()
	doItAndPrint('trellis.device(theme="col.whitebg")')
	command <- paste("plot(allEffects(", .activeModel, "), ask=FALSE)", sep="")
	justDoIt(command)
	logger(command)
	activateMenus()
	NULL
}

addObservationStatistics <- function () {
    .activeDataSet <- ActiveDataSet()
    .activeModel <- ActiveModel()
	if (is.null(.activeModel)) 
		return()
	addVariable <- function(name) {
		variable <- paste(name, ".", .activeModel, sep = "")
		if (is.element(variable, .variables)) {
			ans <- checkReplace(variable)
			if (tclvalue(ans) == "no") 
				return()
		}
		command <- paste(name, "(", .activeModel, ")", sep = "")
		justDoIt(paste(.activeDataSet, "$", variable, " <- ", 
						command, sep = ""))
		logger(paste(.activeDataSet, "$", variable, " <- ", command, 
						sep = ""))
	}
	if (getRcmdr("modelWithSubset")) {
		Message(message = gettextRcmdr("Observation statistics not available\nfor a model fit to a subset of the data."), 
				type = "error")
		tkfocus(CommanderWindow())
		return()
	}
	defaults <- list (initial.fitted = 1, initial.residuals = 1, initial.rstudent = 1, 
			initial.hatvalues = 1, initial.cookd = 1, initial.obsNumbers = 1)
	dialog.values <- getDialog ("addObservationStatistics", defaults)
	initializeDialog(title = gettextRcmdr("Add Observation Statistics to Data"))
	.variables <- Variables()
	obsNumberExists <- is.element("obsNumber", .variables)
	activate <- c(checkMethod("fitted", .activeModel, default = TRUE, 
					reportError = FALSE), checkMethod("residuals", .activeModel, 
					default = TRUE, reportError = FALSE), checkMethod("rstudent", 
					.activeModel, reportError = FALSE), checkMethod("hatvalues", 
					.activeModel, reportError = FALSE), checkMethod("cooks.distance", 
					.activeModel, reportError = FALSE))
	checkBoxes(frame = "selectFrame", boxes = c(c("fitted", "residuals", 
							"rstudent", "hatvalues", "cookd")[activate], "obsNumbers"), 
			labels = c(gettextRcmdr(c("Fitted values", "Residuals", 
									"Studentized residuals", "Hat-values", "Cook's distances"))[activate], 
					gettextRcmdr("Observation indices")), initialValues = c(dialog.values$initial.fitted, 
					dialog.values$initial.residuals, dialog.values$initial.rstudent, 
					dialog.values$initial.hatvalues, dialog.values$initial.cookd, dialog.values$initial.obsNumbers))
	onOK <- function() {
		closeDialog()
		if (activate[1] && tclvalue(fittedVariable) == 1) 
			addVariable("fitted")
		if (activate[2] && tclvalue(residualsVariable) == 1) 
			addVariable("residuals")
		if (activate[3] && tclvalue(rstudentVariable) == 1) 
			addVariable("rstudent")
		if (activate[4] && tclvalue(hatvaluesVariable) == 1) 
			addVariable("hatvalues")
		if (activate[5] && tclvalue(cookdVariable) == 1) 
			addVariable("cooks.distance")
		obsNumbers <- tclvalue(obsNumbersVariable)
		putDialog ("addObservationStatistics", list (initial.fitted = tclvalue (fittedVariable),
						initial.residuals = tclvalue (residualsVariable), initial.rstudent = tclvalue(rstudentVariable), 
						initial.hatvalues = tclvalue (hatvaluesVariable), initial.cookd = tclvalue (cookdVariable), 
						initial.obsNumbers = obsNumbers))
		if (tclvalue(obsNumbersVariable) == 1) {
			proceed <- if (obsNumberExists) 
						tclvalue(checkReplace("obsNumber"))
					else "yes"  
			if (proceed == "yes") {
				command <- paste(.activeDataSet, "$obsNumber <- 1:nrow(", 
						.activeDataSet, ")", sep = "")
				justDoIt(command)
				logger(command)
			}
		}
		activeDataSet(.activeDataSet, flushModel = FALSE, flushDialogMemory = FALSE)
		tkfocus(CommanderWindow())
	}
	OKCancelHelp(helpSubject = "influence.measures", reset = "addObservationStatistics")
	tkgrid(selectFrame, sticky = "w")
	tkgrid(buttonsFrame, sticky = "w")
	dialogSuffix(rows = 5, columns = 1)
}

residualQQPlot <- function () {
    Library("car")
    .activeModel <- ActiveModel()
    if (is.null(.activeModel) || !checkMethod("qqPlot", .activeModel)) 
        return()
    defaults <- list (initial.simulate = 1, initial.identify = "auto", initial.id.n="2")
    dialog.values <- getDialog ("residualQQPlot", defaults)
    initializeDialog(title = gettextRcmdr("Residual Quantile-Comparison Plot"))
    selectFrame <- tkframe(top)
    simulateVar <- tclVar(dialog.values$initial.simulate)
    simulateCheckBox <- ttkcheckbutton(selectFrame, variable = simulateVar)
    identifyPointsFrame <- tkframe(top)
    radioButtons(identifyPointsFrame, name = "identify", buttons = c("auto", "mouse", 
        "not"), labels = gettextRcmdr(c("Automatically", 
            "Interactively with mouse", "Do not identify")), title = gettextRcmdr("Identify Points"), 
        initialValue = dialog.values$initial.identify)    
    id.n.Var <- tclVar(dialog.values$initial.id.n) 
    npointsSpinner <- tkspinbox(identifyPointsFrame, from=1, to=10, width=2, textvariable=id.n.Var)      
    onOK <- function() {
        simulate <- tclvalue (simulateVar)  
        id.n <- tclvalue(id.n.Var)
        identify <- tclvalue(identifyVariable)
        method <- if (identify == "mouse") "identify" else "y"
        id.n.use <- if (identify == "not") 0 else id.n   
        closeDialog()
        if (is.na(suppressWarnings(as.numeric(id.n))) || round(as.numeric(id.n)) != as.numeric(id.n)){
            errorCondition(recall = residualQQPlot, message = gettextRcmdr("number of points to identify must be an integer"))
            return()
        }
        putDialog ("residualQQPlot", list (initial.simulate = simulate, initial.identify = identify, initial.id.n=id.n))
        simulate <- tclvalue(simulateVar) == 1
        if (identify == "mouse") {
            RcmdrTkmessageBox(title = "Identify Points", message = paste(gettextRcmdr("Use left mouse button to identify points,\n"), 
                gettextRcmdr(if (MacOSXP()) 
                    "esc key to exit."
                    else "right button to exit."), sep = ""), icon = "info", 
                type = "ok")
        }
        command <- paste("qqPlot(", .activeModel, ", simulate=", 
            simulate, ', id.method="', method, '", id.n=', id.n.use,  ")", sep = "")
        if (identify == "mouse") command <- suppressMarkdown(command)
        doItAndPrint(command)
        activateMenus()
        tkfocus(CommanderWindow())
    }
    OKCancelHelp(helpSubject = "qqPlot.lm", reset = "residualQQPlot")
    tkgrid(labelRcmdr(selectFrame, text = gettextRcmdr("Simulated confidence envelope")), 
        simulateCheckBox, sticky = "w")
    tkgrid(selectFrame, sticky = "w")
    tkgrid(identifyFrame, sticky="w")
    tkgrid(labelRcmdr(identifyPointsFrame, text=gettextRcmdr("Number of points to identify  ")), npointsSpinner, sticky="w")
    tkgrid(identifyPointsFrame, sticky="w")
    tkgrid(buttonsFrame, sticky = "w")
    dialogSuffix(rows = 2, columns = 1)
}

testLinearHypothesis <- function(){
	# coef.multinom <- car:::coef.multinom
	defaults <- list(previous.model=NULL, nrows=1, table.values=0, rhs.values=0)
	dialog.values <- getDialog("testLinearHypothesis", defaults=defaults)
	Library("car")
	.activeModel <- ActiveModel()
	if (is.null(.activeModel) || !checkMethod("linearHypothesis", .activeModel, default=TRUE)) return()
	if (!is.null(dialog.values$previous.model)){
		if (dialog.values$previous.model != .activeModel){
			dialog.values <- defaults
		}
	}
	table.values <- dialog.values$table.values
	rhs.values <- dialog.values$rhs.values
	env <- environment()
	initializeDialog(title=gettextRcmdr("Test Linear Hypothesis"))
	outerTableFrame <- tkframe(top)
	assign(".tableFrame", tkframe(outerTableFrame), envir=env)
	setUpTable <- function(...){
		tkdestroy(get(".tableFrame", envir=env))
		assign(".tableFrame", tkframe(outerTableFrame), envir=env)
		nrows <- as.numeric(tclvalue(rowsValue))
		if (length(table.values) == 1 && table.values == 0) {
			table.values <- matrix(0, nrows, ncols)
			rhs.values <- rep(0, nrows)
		}
		if (nrow(table.values) < nrows){
			add.rows <- nrows - nrow(table.values)
			table.values <- rbind(table.values, matrix(0, add.rows, ncols))
			rhs.values <- c(rhs.values, rep(0, add.rows))
		}
		col.names <- names(coef(get(.activeModel)))
		col.names <- substring(paste(abbreviate(col.names, 12), "            "), 1, 12)
		make.col.names <- "labelRcmdr(.tableFrame, text='')"
		for (j in 1:ncols) {
			make.col.names <- paste(make.col.names, ", ", 
					"labelRcmdr(.tableFrame, text='", col.names[j], "')", sep="")
		}
		rhsText <- gettextRcmdr("Right-hand side")
		make.col.names <- paste(make.col.names, ", labelRcmdr(.tableFrame, text='          ')",
				", labelRcmdr(.tableFrame, text='", rhsText, "')", sep="")
		eval(parse(text=paste("tkgrid(", make.col.names, ")", sep="")), envir=env)
		for (i in 1:nrows){   
			varname <- paste(".tab.", i, ".1", sep="") 
			rhs.name <- paste(".rhs.", i, sep="")
			assign(varname, tclVar(table.values[i, 1]) , envir=env)
			assign(rhs.name, tclVar(rhs.values[i]), envir=env)
			make.row <- paste("labelRcmdr(.tableFrame, text=", i, ")")
			make.row <- paste(make.row, ", ", "ttkentry(.tableFrame, width='5', textvariable=", 
					varname, ")", sep="")
			for (j in 2:ncols){
				varname <- paste(".tab.", i, ".", j, sep="")
				assign(varname, tclVar(table.values[i, j]), envir=env)
				make.row <- paste(make.row, ", ", "ttkentry(.tableFrame, width='5', textvariable=", 
						varname, ")", sep="")
			}
			make.row <- paste(make.row, ", labelRcmdr(.tableFrame, text='     '),",
					"ttkentry(.tableFrame, width='5', textvariable=", rhs.name, ")", sep="")
			eval(parse(text=paste("tkgrid(", make.row, ")", sep="")), envir=env)
		}
		tkgrid(get(".tableFrame", envir=env), sticky="w")
	}
	ncols <- length(coef(get(.activeModel)))
	rowsFrame <- tkframe(top)
	rowsValue <- tclVar(dialog.values$nrows)
	rowsSlider <- tkscale(rowsFrame, from=1, to=ncols, showvalue=FALSE, variable=rowsValue,
			resolution=1, orient="horizontal", command=setUpTable)
	rowsShow <- labelRcmdr(rowsFrame, textvariable=rowsValue, width=2, justify="right")
	onOK <- function(){
		nrows <- as.numeric(tclvalue(rowsValue))
		cell <- 0
		values <- rep(NA, nrows*ncols)
		rhs <- rep(NA, nrows)
		for (i in 1:nrows){
			rhs.name <- paste(".rhs.", i, sep="")
			rhs[i] <- as.numeric(eval(parse(text=paste("tclvalue(", rhs.name,")", sep=""))))
			for (j in 1:ncols){
				cell <- cell+1
				varname <- paste(".tab.", i, ".", j, sep="")
				values[cell] <- as.numeric(eval(parse(text=paste("tclvalue(", varname,")", sep=""))))
			}
		}
		values <- na.omit(values)
		closeDialog()
		if (length(values) != nrows*ncols){
			Message(message=sprintf(gettextRcmdr("Number of valid entries in hypothesis matrix(%d)\nnot equal to number of rows (%d) * number of columns (%d)."), 
							length(values), nrows, ncols), type="error")
			testLinearHypothesis()
			return()
		}
		if (qr(matrix(values, nrows, ncols, byrow=TRUE))$rank < nrows) {
			Message(message=gettextRcmdr("Hypothesis matrix is not of full row rank."),
					type="error")
			testLinearHypothesis()
			return()
		}            
		rhs <- na.omit(rhs)
		if (length(rhs) != nrows){
			errorCondition(recall=testLinearHypothesis, message=sprintf(gettextRcmdr("Number of valid entries in rhs vector (%d)\nis not equal to number of rows (%d)."), length(rhs), nrows))
			return()
		}
		command <- paste("matrix(c(", paste(values, collapse=","), "), ", nrows, ", ", ncols,
				", byrow=TRUE)", sep="")
# 		assign(".Hypothesis", justDoIt(command), envir=.GlobalEnv)
# 		logger(paste(".Hypothesis <- ", command, sep=""))
		doItAndPrint(paste(".Hypothesis <- ", command, sep=""))
		command <- paste("c(", paste(rhs, collapse=","), ")", sep="")
# 		assign(".RHS", justDoIt(command), envir=.GlobalEnv)
# 		logger(paste(".RHS <- ", command, sep=""))
		doItAndPrint(paste(".RHS <- ", command, sep=""))
		rhs.values <- .RHS
		command <- paste("linearHypothesis(", .activeModel, ", .Hypothesis, rhs=.RHS)", sep="")
		doItAndPrint(command)
		justDoIt("remove(.Hypothesis, .RHS, envir=.GlobalEnv)") 
		logger("remove(.Hypothesis, .RHS)")                                              
		tkfocus(CommanderWindow())
		contrast.table <- matrix(values, nrows, ncols, byrow=TRUE)
		putDialog("testLinearHypothesis", list(previous.model=.activeModel, nrows=nrows, table.values=contrast.table,
						rhs.values=rhs.values))
	}
	OKCancelHelp(helpSubject="linearHypothesis", reset="testLinearHypothesis")
	tkgrid(labelRcmdr(rowsFrame, text=gettextRcmdr("Number of Rows:")), rowsSlider, rowsShow, sticky="w")
	tkgrid(rowsFrame, sticky="w")
	tkgrid(labelRcmdr(top, text=gettextRcmdr("Enter hypothesis matrix and right-hand side vector:"), fg=getRcmdr("title.color")), sticky="w")
	tkgrid(outerTableFrame, sticky="w")
	tkgrid(labelRcmdr(top, text=""))
	tkgrid(buttonsFrame, sticky="w")
	dialogSuffix(rows=4, columns=1)       
} 

compareModels <- function () {
	modelPosn <- function(model){
		if (is.null(model)) return(NULL)
		if (!(model %in% models)) NULL
		else which(model == models) - 1
	}
	defaults <- list (initial.model1 = NULL, initial.model2 = NULL)
	dialog.values <- getDialog ("compareModels", defaults)  
	models <- listAllModels()
	if (length(models) < 2) {
		Message(message = gettextRcmdr("There are fewer than two models."), 
				type = "error")
		tkfocus(CommanderWindow())
		return()
	}
	initializeDialog(title = gettextRcmdr("Compare Models"))
	modelsBox1 <- variableListBox(top, models, title = gettextRcmdr("First model (pick one)"),
			initialSelection = modelPosn(dialog.values$initial.model1))
	modelsBox2 <- variableListBox(top, models, title = gettextRcmdr("Second model (pick one)"),
			initialSelection = modelPosn(dialog.values$initial.model2))
	onOK <- function() {
		model1 <- getSelection(modelsBox1)
		model2 <- getSelection(modelsBox2)
		closeDialog()
		putDialog ("compareModels", list (initial.model1 = model1, initial.model2 = model2))
		if (length(model1) == 0 || length(model2) == 0) {
			errorCondition(recall = compareModels, message = gettextRcmdr("You must select two models."))
			return()
		}
		if (!checkMethod("anova", model1)) {
			return()
		}
		if (!class(get(model1, envir = .GlobalEnv))[1] == class(get(model2, 
						envir = .GlobalEnv))[1]) {
			Message(message = gettextRcmdr("Models are not of the same class."), 
					type = "error")
			compareModels()
			return()
		}
		if (glmP()) {
			family1 <- eval(parse(text = paste(model1, "$family$family", 
									sep = "")))
			family2 <- eval(parse(text = paste(model2, "$family$family", 
									sep = "")))
			if (family1 != family2) {
				Message(message = gettextRcmdr("Models do not have the same family."), 
						type = "error")
				compareModels()
				return()
			}
			test <- if (family1 %in% c("binomial", "poisson")) 
						"Chisq"
					else "F"
			doItAndPrint(paste("anova(", model1, ", ", model2, 
							", test=\"", test, "\")", sep = ""))
		}
		else doItAndPrint(paste("anova(", model1, ", ", model2, 
							")", sep = ""))
		tkfocus(CommanderWindow())
	}
	OKCancelHelp(helpSubject = "anova", reset = "compareModels")
	tkgrid(getFrame(modelsBox1), getFrame(modelsBox2), sticky = "nw")
	tkgrid(buttonsFrame, columnspan = 2, sticky = "w")
	dialogSuffix(rows = 2, columns = 2)
}

BreuschPaganTest <- function () {
    .activeModel <- ActiveModel()
	if (is.null(.activeModel)) 
		return()
	Library("lmtest")
	currentModel <- FALSE
	defaults <- list (initial.var = "fitted", initial.student = 0)
	dialog.values <- getDialog ("BreuschPaganTest", defaults)
	initializeDialog(title = gettextRcmdr("Breusch-Pagan Test"))
	tkgrid(labelRcmdr(top, text = gettextRcmdr("Score Test for Nonconstant Error Variance"), 
					fg = getRcmdr("title.color")), sticky = "w")
	optionsFrame <- tkframe(top)
	onOK <- function() {
		student <- tclvalue(studentVariable)
		var <- tclvalue(varVariable)
		putDialog ("BreuschPaganTest", list (initial.var = var, initial.student = student))
		type <- if (var == "fitted") 
					paste(", varformula = ~ fitted.values(", .activeModel, 
							")", sep = "")
				else if (var == "predictors") 
					""
				else paste(", varformula = ~", tclvalue(rhsVariable), 
							sep = "")
		model.formula <- as.character(formula(get(.activeModel)))
		model.formula <- paste(model.formula[2], "~", model.formula[3])
		closeDialog()
		student <- if (tclvalue(studentVariable) == 1) 
					"TRUE"
				else "FALSE"
		command <- paste("bptest(", model.formula, type, ", studentize=", 
				student, ", data=", ActiveDataSet(), ")", sep = "")
		doItAndPrint(command)
		tkfocus(CommanderWindow())
	}
	OKCancelHelp(helpSubject = "bptest", reset = "BreuschPaganTest")
	studentVariable <- tclVar(dialog.values$initial.student)
	studentFrame <- tkframe(optionsFrame)
	studentCheckBox <- ttkcheckbutton(studentFrame, variable = studentVariable)
	tkgrid(labelRcmdr(studentFrame, text = gettextRcmdr("Studentized test statistic"), 
					justify = "left"), studentCheckBox, sticky = "w")
	tkgrid(studentFrame, sticky = "w")
	radioButtons(optionsFrame, name = "var", buttons = c("fitted", 
					"predictors", "other"), labels = gettextRcmdr(c("Fitted values", 
							"Explanatory variables", "Other (specify)")), title = gettextRcmdr("Variance Formula"), 
			initialValue = dialog.values$initial.var)
	tkgrid(varFrame, sticky = "w")
	modelFormula(optionsFrame, hasLhs = FALSE)
	tkgrid(formulaFrame, sticky = "w")
	tkgrid(outerOperatorsFrame)
	tkgrid(getFrame(xBox), sticky = "w")
	tkgrid(optionsFrame, sticky = "w")
	tkgrid(buttonsFrame, sticky = "w")
	dialogSuffix(rows = 4, columns = 1)
}

DurbinWatsonTest <- function () {
    .activeModel <- ActiveModel()
	if (is.null(.activeModel)) 
		return()
	Library("lmtest")
	defaults <- list (initial.altHypothesis = "greater")
	dialog.values <- getDialog ("DurbinWatsonTest", defaults)
	initializeDialog(title = gettextRcmdr("Durbin-Waton Test"))
	tkgrid(labelRcmdr(top, text = gettextRcmdr("Test for First-Order Error Autocorrelation"), 
					fg = getRcmdr("title.color")), sticky = "w")
	onOK <- function() {
		altHypothesis <- tclvalue(altHypothesisVariable)
		putDialog ("DurbinWatsonTest", list(initial.altHypothesis = altHypothesis))
		closeDialog()
		model.formula <- as.character(formula(get(ActiveModel())))
		model.formula <- paste(model.formula[2], "~", model.formula[3])
		command <- paste("dwtest(", model.formula, ", alternative=\"", 
				altHypothesis, "\", data=", ActiveDataSet(), ")", 
				sep = "")
		doItAndPrint(command)
		tkfocus(CommanderWindow())
	}
	OKCancelHelp(helpSubject = "dwtest", reset = "DurbinWatsonTest")
	radioButtons(name = "altHypothesis", buttons = c("greater", 
					"notequal", "less"), values = c("greater", "two.sided", 
					"less"), labels = c("rho >  0", "rho != 0", "rho <  0"), 
			title = gettextRcmdr("Alternative Hypothesis"), 
			initialValue = dialog.values$initial.altHypothesis)
	tkgrid(altHypothesisFrame, sticky = "w")
	tkgrid(buttonsFrame, sticky = "w")
	dialogSuffix(rows = 3, columns = 1)
}

RESETtest <- function () {
    .activeModel <- ActiveModel()
	if (is.null(.activeModel)) 
		return()
	Library("lmtest")
	defaults <- list (initial.square = 1, initial.cube = 1, initial.type = "regressor")
	dialog.values <- getDialog ("RESETtest", defaults)
	initializeDialog(title = gettextRcmdr("RESET Test"))
	tkgrid(labelRcmdr(top, text = gettextRcmdr("Test for Nonlinearity"), 
					fg = getRcmdr("title.color")), sticky = "w")
	onOK <- function() {
		type <- tclvalue(typeVariable)
		square <- tclvalue(squareVariable)
		cube <- tclvalue(cubeVariable)
		putDialog ("RESETtest", list (initial.square = square, initial.cube = cube, initial.type = type))
		closeDialog()
		model.formula <- as.character(formula(get(ActiveModel())))
		model.formula <- paste(model.formula[2], "~", model.formula[3])
		if (square == "0" && cube == "0") {
			errorCondition(recall = RESETtest, message = gettextRcmdr("No powers are checked."))
			return()
		}
		powers <- if (square == "1" && cube == "1") 
					"2:3"
				else if (square == "1" && cube == "0") 
					"2"
				else if (square == "0" && cube == "1") 
					"3"
		command <- paste("resettest(", model.formula, ", power=", 
				powers, ", type=\"", type, "\", data=", ActiveDataSet(), 
				")", sep = "")
		doItAndPrint(command)
		tkfocus(CommanderWindow())
	}
	OKCancelHelp(helpSubject = "reset", reset = "RESETtest")
	optionsFrame <- tkframe(top)
	squareVariable <- tclVar(dialog.values$initial.square)
	squareCheckBox <- ttkcheckbutton(optionsFrame, variable = squareVariable)
	cubeVariable <- tclVar(dialog.values$initial.cube)
	cubeCheckBox <- ttkcheckbutton(optionsFrame, variable = cubeVariable)
	typeVariable <- tclVar("regressor")
	radioButtons(optionsFrame, name = "type", buttons = c("regressor", 
					"fitted", "princomp"), labels = gettextRcmdr(c("Explanatory variables", 
							"Fitted values", "First principal component")), title = gettextRcmdr("Type of Test"), 
			initialValue = dialog.values$initial.type)
	tkgrid(labelRcmdr(optionsFrame, text = gettextRcmdr("Powers to Include"), 
					fg = getRcmdr("title.color")), sticky = "w")
	tkgrid(labelRcmdr(optionsFrame, text = gettextRcmdr("2 (squares)")), 
			squareCheckBox, sticky = "w")
	tkgrid(labelRcmdr(optionsFrame, text = gettextRcmdr("3 (cubes)   ")), 
			cubeCheckBox, sticky = "w")
	tkgrid(typeFrame, sticky = "w")
	tkgrid(optionsFrame, sticky = "w")
	tkgrid(buttonsFrame, sticky = "w")
	dialogSuffix(rows = 3, columns = 1)
}

OutlierTest <- function(){
    .activeModel <- ActiveModel()
	if (is.null(.activeModel)) return()
	Library("car")
	if (!checkMethod("outlierTest", .activeModel)) {
		errorCondition(gettextRcmdr("There is no appropriate outlierTest method for a model of this class."))
		return()
	}
	doItAndPrint(paste("outlierTest(", .activeModel, ")", sep=""))
}

confidenceIntervals <- function () {
    .activeModel <- ActiveModel()
    if (is.null(.activeModel)) 
        return()
    Library("MASS")
    defaults <- list (initial.level = "0.95", initial.statistic="LR")
    dialog.values <- getDialog ("confidenceIntervals", defaults)
    initializeDialog(title = gettextRcmdr("Confidence Intervals"))
    tkgrid(labelRcmdr(top, text = gettextRcmdr("Confidence Intervals for Individual Coefficients"), 
                      fg = getRcmdr("title.color")), sticky = "w")
    onOK <- function() {
        level <- tclvalue(confidenceLevel)
        opts <- options(warn = -1)
        lev <- as.numeric(level)
        options(opts)
        closeDialog()
        if ((is.na(lev)) || !is.numeric(lev) || (lev < 0) || (lev > 1)) {
            Message(gettextRcmdr("Confidence level must be a number between 0 and 1."),
                    type="error")
            confidenceIntervals()
            return()
        }
        putDialog ("confidenceIntervals", list (initial.level = level,
                                                initial.statistic = if(glm) tclvalue(typeVariable) else "LR"))
        command <- if (glm) 
            paste("Confint(", .activeModel, ", level=", level, 
                  ", type=\"", tclvalue(typeVariable), "\")", sep = "")
        else paste("Confint(", .activeModel, ", level=", level, 
                   ")", sep = "")
        doItAndPrint(command)
        tkfocus(CommanderWindow())
    }
    OKCancelHelp(helpSubject = "Confint", reset = "confidenceIntervals")
    confidenceFrame <- tkframe(top)
    confidenceLevel <- tclVar(dialog.values$initial.level)
    confidenceField <- ttkentry(confidenceFrame, width = "6", 
                                textvariable = confidenceLevel)
    radioButtons(top, name = "type", buttons = c("LR", "Wald"), initialValue=dialog.values$initial.statistic,
                 labels = gettextRcmdr(c("Likelihood-ratio statistic", 
                                         "Wald statistic")), title = gettextRcmdr("Test Based On"))
    tkgrid(labelRcmdr(confidenceFrame, text = gettextRcmdr("Confidence Level: ")), 
           confidenceField, sticky = "w")
    tkgrid(confidenceFrame, sticky = "w")
    glm <- class(get(.activeModel))[1] == "glm"
    if (glm) 
        tkgrid(typeFrame, sticky = "w")
    tkgrid(buttonsFrame, sticky = "w")
    dialogSuffix(rows = 3 + glm, columns = 1)
}

aic <- function(){
	.activeModel <- ActiveModel()
	if (is.null(.activeModel)) return()
	doItAndPrint(paste("AIC(", .activeModel, ")", sep=""))
}

bic <- function(){
	.activeModel <- ActiveModel()
	if (is.null(.activeModel)) return()
	doItAndPrint(paste("BIC(", .activeModel, ")", sep=""))
}

stepwiseRegression <- function () {
	defaults <- list (initial.direction = "backward/forward", initial.criterion = "BIC")
	dialog.values <- getDialog ("stepwiseRegression", defaults)
	initializeDialog(title = gettextRcmdr("Stepwise Model Selection"))
	onOK <- function() {
		direction <- as.character(tclvalue(directionVariable))
		criterion <- as.character(tclvalue(criterionVariable))
		putDialog ("stepwiseRegression", list (initial.direction = tclvalue(directionVariable), 
						initial.criterion = tclvalue(criterionVariable)))
		closeDialog()
		doItAndPrint(paste("stepwise(", ActiveModel(), ", direction='", 
						direction, "', criterion='", criterion, "')", sep = ""))
		tkdestroy(top)
		tkfocus(CommanderWindow())
	}
	OKCancelHelp(helpSubject = "stepwise", reset = "stepwiseRegression")
	radioButtons(top, name = "direction", buttons = c("bf", "fb", 
					"b", "f"), values = c("backward/forward", "forward/backward", 
					"backward", "forward"), labels = gettextRcmdr(c("backward/forward", 
							"forward/backward", "backward", "forward")), title = gettextRcmdr("Direction"), 
			initialValue = dialog.values$initial.direction)
	radioButtons(top, name = "criterion", buttons = c("bic", 
					"aic"), values = c("BIC", "AIC"), labels = gettextRcmdr(c("BIC", 
							"AIC")), title = gettextRcmdr("Criterion"), initialValue = dialog.values$initial.criterion)
	tkgrid(directionFrame, criterionFrame, sticky = "nw")
	tkgrid(buttonsFrame, columnspan = 2, sticky = "w")
	dialogSuffix(rows = 2, columns = 2)
}

subsetRegression <- function () {
	Library("leaps")
	defaults <- list (initial.criterion = "bic", initial.nbest = 1)
	dialog.values <- getDialog ("subsetRegression", defaults)
	initializeDialog(title = gettextRcmdr("Subset Model Selection"))
	onOK <- function() {
		formula <- paste(sub("^[ ]*", "", deparse(formula(get(ActiveModel())))), 
				collapse = "")
		criterion <- as.character(tclvalue(criterionVariable))
		nbest <- as.numeric(tclvalue(nbestValue))
		putDialog ("subsetRegression", list (initial.criterion = criterion, initial.nbest = nbest))
		nvmax <- as.numeric(tclvalue(nvmaxValue))
		really.big <- if (nvmax > 50) 
					"TRUE"
				else "FALSE"
		closeDialog()
		doItAndPrint(paste("plot(regsubsets(", formula, ", data=", 
						ActiveDataSet(), ", nbest=", nbest, ", nvmax=", nvmax, 
						"), scale='", criterion, "')", sep = ""))
		tkdestroy(top)
		tkfocus(CommanderWindow())
	}
	OKCancelHelp(helpSubject = "regsubsets", reset = "subsetRegression")
	radioButtons(top, name = "criterion", buttons = c("bic", 
					"Cp", "adjr2", "r2"), labels = gettextRcmdr(c("BIC", 
							"Mallows Cp", "Adjusted R-sq.", "R-squared")), title = gettextRcmdr("Criterion for Model Plot"), 
			initialValue = dialog.values$initial.criterion)
	nvar <- ncol(model.matrix(get(ActiveModel())))
	nbestValue <- tclVar(dialog.values$initial.nbest)
	nvmaxValue <- tclVar(as.character(min(25, nvar)))
	slidersFrame <- tkframe(top)
	nbestSlider <- tkscale(slidersFrame, from = 1, to = 10, showvalue = TRUE, 
			variable = nbestValue, resolution = 1, orient = "horizontal")
	nvmaxSlider <- tkscale(slidersFrame, from = 1, to = nvar, 
			showvalue = TRUE, variable = nvmaxValue, resolution = 1, 
			orient = "horizontal")
	tkgrid(tklabel(slidersFrame, text = "     "), tklabel(slidersFrame, 
					text = gettextRcmdr("Number of best models\nof each size:"), 
					fg = getRcmdr("title.color")), nbestSlider, sticky = "w")
	tkgrid(tklabel(slidersFrame, text = "     "), tklabel(slidersFrame, 
					text = gettextRcmdr("Maximum size:"), fg = getRcmdr("title.color")), nvmaxSlider, 
			sticky = "e")
	tkgrid(criterionFrame, slidersFrame, sticky = "nw")
	tkgrid(buttonsFrame, columnspan = 2, sticky = "w")
	dialogSuffix(rows = 2, columns = 2)
}