Nothing
# Model menu dialogs
# last modified 2014-08-01 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"), font="RcmdrTitleFont", 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()
}
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(){
.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", apply = "CRPlots")
tkgrid(labelRcmdr(sliderFrame, text=gettextRcmdr("Span for smooth")), slider, sticky="sw")
tkgrid(sliderFrame, sticky="w")
tkgrid(buttonsFrame, sticky="w")
dialogSuffix()
}
AVPlots <- function () {
.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", apply = "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()
}
InfluencePlot <- function () {
.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", apply = "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()
}
anovaTable <- function () {
.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()
}
VIF <- function(){
.activeModel <- ActiveModel()
if (is.null(.activeModel) || !checkMethod("vif", .activeModel)) return()
doItAndPrint(paste("vif(", .activeModel, ")", sep=""))
}
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()
}
paste(variable, " <- ", name, "(", .activeModel, ")", 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))
command <- paste(.activeDataSet, "<- within(", .activeDataSet, ", {", sep="")
onOK <- function() {
closeDialog()
if (activate[1] && tclvalue(fittedVariable) == 1)
command <- paste(command, "\n ", addVariable("fitted"), sep="")
if (activate[2] && tclvalue(residualsVariable) == 1)
command <- paste(command, "\n ", addVariable("residuals"), sep="")
if (activate[3] && tclvalue(rstudentVariable) == 1)
command <- paste(command, "\n ", addVariable("rstudent"), sep="")
if (activate[4] && tclvalue(hatvaluesVariable) == 1)
command <- paste(command, "\n ", addVariable("hatvalues"), sep="")
if (activate[5] && tclvalue(cookdVariable) == 1)
command <- paste(command, "\n ", addVariable("cooks.distance"), sep="")
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(command, "\n obsNumber <- 1:nrow(", .activeDataSet, ")", sep = "")
}
}
command <- paste(command, "\n})")
result <- doItAndPrint(command)
if (class(result) != "try-error")activeDataSet(.activeDataSet, flushModel = FALSE, flushDialogMemory = FALSE)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject = "influence.measures", reset = "addObservationStatistics")
tkgrid(selectFrame, sticky = "w")
tkgrid(buttonsFrame, sticky = "w")
dialogSuffix()
}
residualQQPlot <- function () {
.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", apply = "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()
}
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)
.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.1 <- paste(".Hypothesis <- matrix(c(", paste(values, collapse=","), "), ", nrows, ", ", ncols,
", byrow=TRUE)", sep="")
command.2 <- paste(".RHS <- c(", paste(rhs, collapse=","), ")", sep="")
justDoIt(paste("putRcmdr('.RHS', c(", paste(rhs, collapse=","), "))", sep=""))
command.3 <- paste("linearHypothesis(", .activeModel, ", .Hypothesis, rhs=.RHS)", sep="")
doItAndPrint(paste("local({\n", " ", command.1, "\n",
" ", command.2, "\n",
" ", command.3, "\n",
"})", sep=""))
tkfocus(CommanderWindow())
contrast.table <- matrix(values, nrows, ncols, byrow=TRUE)
putDialog("testLinearHypothesis", list(previous.model=.activeModel, nrows=nrows, table.values=contrast.table,
rhs.values=getRcmdr(".RHS")))
}
OKCancelHelp(helpSubject="linearHypothesis", reset="testLinearHypothesis", apply="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"), font="RcmdrTitleFont"), sticky="w")
tkgrid(outerTableFrame, sticky="w")
tkgrid(labelRcmdr(top, text=""))
tkgrid(buttonsFrame, sticky="w")
dialogSuffix()
}
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", apply = "compareModels")
tkgrid(getFrame(modelsBox1), getFrame(modelsBox2), sticky = "nw")
tkgrid(buttonsFrame, columnspan = 2, sticky = "w")
dialogSuffix()
}
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"), font="RcmdrTitleFont"), 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", apply = "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()
}
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"), font="RcmdrTitleFont"), 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()
}
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"), font="RcmdrTitleFont"), 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", apply = "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"), font="RcmdrTitleFont"), 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()
}
OutlierTest <- function(){
.activeModel <- ActiveModel()
if (is.null(.activeModel)) return()
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"), font="RcmdrTitleFont"), 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", apply = "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()
}
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 () {
Library("MASS")
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",
apply = "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()
}
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", apply = "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"), font="RcmdrTitleFont"), nbestSlider, sticky = "w")
tkgrid(tklabel(slidersFrame, text = " "), tklabel(slidersFrame,
text = gettextRcmdr("Maximum size:"), fg = getRcmdr("title.color"), font="RcmdrTitleFont"), nvmaxSlider,
sticky = "e")
tkgrid(criterionFrame, slidersFrame, sticky = "nw")
tkgrid(buttonsFrame, columnspan = 2, sticky = "w")
dialogSuffix()
}
effectPlots <- function () {
Library("effects")
defaults <- list(initial.all.or.pick = "TRUE", initial.predictors = NULL,
initial.partial.res = 0, initial.span = 50, initial.style = "stacked")
dialog.values <- getDialog("effectPlots", defaults)
initializeDialog(title = gettextRcmdr("Model Effect Plots"))
predictors <- all.vars(formula(get(activeModel(), envir=.GlobalEnv))[[3]])
predictorsFrame <- tkframe(top)
radioButtons(predictorsFrame, name = "allEffects", buttons = c("yes", "no"),
values = c("TRUE", "FALSE"),
labels = gettextRcmdr(c("Yes", "No")), title = gettextRcmdr("Plot All High-Order Effects?"),
initialValue = dialog.values$initial.all.or.pick)
predictorsBox <- variableListBox(predictorsFrame, predictors, selectmode = "multiple",
title = gettextRcmdr("Predictors (pick one or more)"),
initialSelection = varPosn(dialog.values$initial.predictors, vars=predictors))
partialResFrame <- tkframe(top)
partialResVariable <- tclVar(dialog.values$initial.partial.res)
partialResCheckBoxFrame <- tkframe(partialResFrame)
partialResCheckBox <- ttkcheckbutton(partialResCheckBoxFrame, variable = partialResVariable)
styleFrame <- tkframe(top)
radioButtons(styleFrame, name="styleButtons", buttons = c("stacked", "lines"),
labels = gettextRcmdr(c("Stacked areas", "Lines with confidence bands")),
title=gettextRcmdr("Style of Graph"), initialValue=dialog.values$initial.style)
sliderValue <- tclVar(dialog.values$initial.span)
sliderFrame <- tkframe(partialResFrame)
slider <- tkscale(sliderFrame, from = 5, to = 100, showvalue = TRUE,
variable = sliderValue, resolution = 5, orient = "horizontal")
onOK <- function() {
predictors <- getSelection(predictorsBox)
allEffects <- as.logical(tclvalue(allEffectsVariable))
partial.residuals <- tclvalue(partialResVariable) == "1"
span <- as.numeric(tclvalue(sliderValue))
style <- tclvalue(styleButtonsVariable)
closeDialog()
if (allEffects){
command <- if (class(get(activeModel(), envir=.GlobalEnv))[1] %in% c("multinom", "polr"))
paste("plot(allEffects(", activeModel(), '), style="', style, '")', sep="")
else paste("plot(allEffects(", activeModel(),
if (partial.residuals) paste(", partial.residuals=TRUE), span=", span/100, ")", sep="")
else "))", sep="")
doItAndPrint(command)
predictors <- NULL
}
else {
if (length(predictors) == 0) {
errorCondition(recall = effectPlots,
message = gettextRcmdr("You must select one or more predictors\n or plot all high-order effects."))
return()
}
if (partial.residuals && (all(predictors %in% Factors()))){
errorCondition(recall = effectPlots,
message = gettextRcmdr("To plot partial residuals,\n there must be a least one numeric predictor."))
return()
}
command <- if (class(get(activeModel(), envir=.GlobalEnv))[1] %in% c("multinom", "polr"))
paste("plot(Effect(c(", paste(paste('"', predictors, '"', sep=""), collapse=", "), "), ",
activeModel(), '), style="', style, '")', sep="")
else paste("plot(Effect(c(", paste(paste('"', predictors, '"', sep=""), collapse=", "), "), ", activeModel(),
if (partial.residuals) paste(", partial.residuals=TRUE), span=", span/100, ")", sep="")
else "))", sep = "")
doItAndPrint(command)
}
putDialog ("effectPlots", list(initial.all.or.pick=as.character(allEffects), initial.predictors=predictors,
initial.partial.res=as.numeric(partial.residuals),
initial.span=span, initial.style=style))
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject = "Effect", reset = "effectPlots", apply = "effectPlots")
tkgrid(allEffectsFrame, sticky="w")
tkgrid(getFrame(predictorsBox), sticky="w")
tkgrid(predictorsFrame, sticky="w")
if (class(get(activeModel(), envir=.GlobalEnv))[1] %in% c("lm", "glm")){
tkgrid(labelRcmdr(partialResFrame, text=" "))
tkgrid(partialResCheckBox,
labelRcmdr(partialResCheckBoxFrame, text=gettextRcmdr("Plot partial residuals")),
sticky="w")
tkgrid(partialResCheckBoxFrame, sticky="w")
tkgrid(slider, labelRcmdr(sliderFrame, text = gettextRcmdr("Span for smooth")),
sticky = "swe", padx=6, pady=6)
tkgrid(sliderFrame, sticky="w")
tkgrid(partialResFrame, sticky="w")
}
else if (class(get(activeModel(), envir=.GlobalEnv))[1] %in% c("multinom", "polr")){
tkgrid(labelRcmdr(styleFrame, text=" "))
tkgrid(styleButtonsFrame, sticky="w")
tkgrid(styleFrame, sticky="w")
}
tkgrid(buttonsFrame, sticky = "w")
dialogSuffix()
}
# 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
# }
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.