« back to all changes in this revision
Viewing changes to R/model-menu.R
- browse files at revision 19
- compare with another revision
- download diff
- download tarball
- view history from revision 19
- Committer: Bazaar Package Importer
- Author(s): Dirk Eddelbuettel
- Date: 2008-04-10 16:33:09 UTC
- mfrom: (1.1.17 upstream)
- Revision ID: james.westby@ubuntu.com-20080410163309-8ir2uhylr0bshcir
Tags: 1.3-14-1
New upstream release
- files removed:
- R/ordinalRegressionModel.R
- files modified:
- DESCRIPTION *
- inst/doc/Getting-Started-with-the-Rcmdr.pdf *
- inst/etc/Nations.txt *
- inst/etc/Rcmdr.xbm *
- inst/etc/model-classes.txt *
- inst/etc/submit.xbm *
- inst/po/ca/LC_MESSAGES/R-Rcmdr.mo *
- inst/po/de/LC_MESSAGES/R-Rcmdr.mo *
- inst/po/es/LC_MESSAGES/R-Rcmdr.mo *
- inst/po/fr/LC_MESSAGES/R-Rcmdr.mo *
- inst/po/id/LC_MESSAGES/R-Rcmdr.mo *
- inst/po/it/LC_MESSAGES/R-Rcmdr.mo *
- inst/po/ja/LC_MESSAGES/R-Rcmdr.mo *
- inst/po/pt_BR/LC_MESSAGES/R-Rcmdr.mo *
- inst/po/ro/LC_MESSAGES/R-Rcmdr.mo *
- inst/po/ru/LC_MESSAGES/R-Rcmdr.mo *
- inst/po/sl/LC_MESSAGES/R-Rcmdr.mo *
- man/Compute.Rd *
- man/Confint.Rd *
- man/KMeans.Rd *
- man/Plugins.Rd *
- man/Rcmdr.sciviews-specific.Rd *
- man/RcmdrPager.Rd *
- man/Recode.Rd *
- man/Scatter3DDialog.Rd *
- man/assignCluster.Rd *
- man/bin.var.Rd *
- man/colPercents.Rd *
- man/generalizedLinearModel.Rd *
- man/hierarchicalCluster.Rd *
- man/linearModel.Rd *
- man/numSummary.Rd *
- man/plotMeans.Rd *
- man/scatter3d.Rd *
- po/R-ca.po *
- po/R-de.po *
- po/R-es.po *
- po/R-fr.po *
- po/R-it.po *
- po/R-ja.po *
- po/R-pt_BR.po *
- po/R-ro.po *
- po/R-ru.po *
- po/R-sl.po *
- po/R-sl_utf-8.po *
added
removed
R/model-menu.R
1
# Model menu dialogs
2
3
# last modified 22 June 07 by J. Fox
4
5
selectActiveModel <- function(){
6
models <- listAllModels()
7
.activeModel <- ActiveModel()
8
if ((length(models) == 1) && !is.null(.activeModel)) {
9
Message(message=gettextRcmdr("There is only one model in memory."),
10
type="warning")
11
tkfocus(CommanderWindow())
12
return()
13
}
14
if (length(models) == 0){
15
Message(message=gettextRcmdr("There are no models from which to choose."),
16
type="error")
17
tkfocus(CommanderWindow())
18
return()
19
}
20
initializeDialog(title=gettextRcmdr("Select Model"))
21
.activeDataSet <- ActiveDataSet()
22
initial <- if (is.null(.activeModel)) NULL else which(.activeModel == models) - 1
23
modelsBox <- variableListBox(top, models, title=gettextRcmdr("Models (pick one)"),
24
initialSelection=initial)
25
onOK <- function(){
26
model <- getSelection(modelsBox)
27
closeDialog()
28
if (length(model) == 0) {
29
tkfocus(CommanderWindow())
30
return()
31
}
32
dataSet <- eval(parse(text=paste("as.character(", model, "$call$data)")))
33
if (length(dataSet) == 0){
34
errorCondition(message=gettextRcmdr("There is no dataset associated with this model."))
35
return()
36
}
37
dataSets <- listDataSets()
38
if (!is.element(dataSet, dataSets)){
39
errorCondition(message=sprintf(gettextRcmdr("The dataset associated with this model, %s, is not in memory."), dataSet))
40
return()
41
}
42
if (is.null(.activeDataSet) || (dataSet != .activeDataSet)) activeDataSet(dataSet)
43
activeModel(model)
44
tkfocus(CommanderWindow())
45
}
46
OKCancelHelp()
47
nameFrame <- tkframe(top)
48
tkgrid(tklabel(nameFrame, fg="blue", text=gettextRcmdr("Current Model: ")),
49
tklabel(nameFrame, text=tclvalue(getRcmdr("modelName"))), sticky="w")
50
tkgrid(nameFrame, sticky="w", columnspan="2")
51
tkgrid(getFrame(modelsBox), columnspan="2", sticky="w")
52
tkgrid(buttonsFrame, columnspan=2, sticky="w")
53
dialogSuffix(rows=3, columns=2)
54
}
55
56
summarizeModel <- function(){
57
.activeModel <- ActiveModel()
58
if (is.null(.activeModel) || !checkMethod("summary", .activeModel)) return()
59
doItAndPrint(paste("summary(", .activeModel, ", cor=FALSE)", sep=""))
60
}
61
62
plotModel <- function(){
63
.activeModel <- ActiveModel()
64
if (is.null(.activeModel) || !checkMethod("plot", .activeModel)) return()
65
command <- "oldpar <- par(oma=c(0,0,3,0), mfrow=c(2,2))"
66
justDoIt(command)
67
logger(command)
68
doItAndPrint(paste("plot(", .activeModel, ")", sep=""))
69
command <- "par(oldpar)"
70
justDoIt(command)
71
logger(command)
72
}
73
74
CRPlots <- function(){
75
require("car")
76
.activeModel <- ActiveModel()
77
if (is.null(.activeModel) || !checkMethod("cr.plot", .activeModel)) return()
78
doItAndPrint(paste("cr.plots(", .activeModel, ", ask=FALSE)", sep=""))
79
activateMenus()
80
}
81
82
AVPlots <- function(){
83
require("car")
84
.activeModel <- ActiveModel()
85
if (is.null(.activeModel) || !checkMethod("av.plot", .activeModel)) return()
86
response <- tclvalue(RcmdrTkmessageBox(message=gettextRcmdr("Identify points with mouse?"),
87
icon="question", type="yesno", default="no"))
88
doItAndPrint(paste("av.plots(", .activeModel, ", ask=FALSE, identify.points=",
89
response=="yes", ")", sep=""))
90
activateMenus()
91
}
92
93
anovaTable <- function(){
94
require("car")
95
.activeModel <- ActiveModel()
96
if (is.null(.activeModel)) return()
97
if (!checkMethod("Anova", .activeModel)) {
98
errorCondition(message=gettextRcmdr("There is no appropriate Anova method for a model of this class."))
99
return()
100
}
101
doItAndPrint(paste("Anova(", .activeModel, ")", sep=""))
102
}
103
104
VIF <- function(){
105
require("car")
106
.activeModel <- ActiveModel()
107
if (is.null(.activeModel) || !checkMethod("vif", .activeModel)) return()
108
doItAndPrint(paste("vif(", .activeModel, ")", sep=""))
109
}
110
111
InfluencePlot <- function(){
112
require("car")
113
.activeModel <- ActiveModel()
114
if (is.null(.activeModel) || !checkMethod("influencePlot", .activeModel)) return()
115
response <- tclvalue(RcmdrTkmessageBox(message=gettextRcmdr("Identify points with mouse?"),
116
icon="question", type="yesno", default="no"))
117
labels <- if (response == "no") ", labels=FALSE" else ""
118
doItAndPrint(paste("influencePlot(", .activeModel, labels, ")", sep=""))
119
}
120
121
effectPlots <- function(){
122
require("effects")
123
.activeModel <- ActiveModel()
124
if (is.null(.activeModel) || !checkMethod("effect", .activeModel)) return()
125
doItAndPrint('trellis.device(theme="col.whitebg")')
126
command <- paste("plot(all.effects(", .activeModel, "), ask=FALSE)", sep="")
127
justDoIt(command)
128
logger(command)
129
activateMenus()
130
NULL
131
}
132
133
addObservationStatistics <- function(){
134
if (is.null(.activeModel)) return()
135
addVariable <- function(name){
136
variable <- paste(name, ".", .activeModel, sep="")
137
if (is.element(variable, .variables)) {
138
ans <- checkReplace(variable)
139
if (tclvalue(ans) == "no") return()
140
}
141
command <- paste(name, "(", .activeModel, ")", sep="")
142
justDoIt(paste(.activeDataSet, "$", variable, " <- ", command, sep=""))
143
logger(paste(.activeDataSet, "$", variable, " <- ", command, sep=""))
144
}
145
if (getRcmdr("modelWithSubset")){
146
Message(message=
147
gettextRcmdr("Observation statistics not available\nfor a model fit to a subset of the data."),
148
type="error")
149
tkfocus(.commander)
150
return()
151
}
152
initializeDialog(title=gettextRcmdr("Add Observation Statistics to Data"))
153
.activeModel <- ActiveModel()
154
.activeDataSet <- ActiveDataSet()
155
.variables <- Variables()
156
obsNumberExists <- is.element("obsNumber", .variables)
157
activate <- c( checkMethod("fitted", .activeModel, default=TRUE, reportError=FALSE),
158
checkMethod("residuals", .activeModel, default=TRUE, reportError=FALSE),
159
checkMethod("rstudent", .activeModel, reportError=FALSE),
160
checkMethod("hatvalues", .activeModel, reportError=FALSE),
161
checkMethod("cooks.distance", .activeModel, reportError=FALSE))
162
checkBoxes(frame="selectFrame", boxes=c(c("fitted", "residuals", "rstudent", "hatvalues", "cookd")[activate],
163
"obsNumbers"),
164
initialValues=c(rep(1, sum(activate)), if(obsNumberExists) "0" else "1"),
165
labels=c(gettextRcmdr(c("Fitted values", "Residuals", "Studentized residuals", "Hat-values", "Cook's distances"))[activate],
166
gettextRcmdr("Observation indices")))
167
onOK <- function(){
168
closeDialog()
169
if (activate[1] && tclvalue(fittedVariable) == 1) addVariable("fitted")
170
if (activate[2] && tclvalue(residualsVariable) == 1) addVariable("residuals")
171
if (activate[3] && tclvalue(rstudentVariable) == 1) addVariable("rstudent")
172
if (activate[4] && tclvalue(hatvaluesVariable) == 1) addVariable("hatvalues")
173
if (activate[5] && tclvalue(cookdVariable) == 1) addVariable("cooks.distance")
174
if (tclvalue(obsNumbersVariable) == 1){
175
proceed <- if (obsNumberExists) tclvalue(checkReplace("obsNumber")) else "yes"
176
if (proceed == "yes") {
177
command <- paste(.activeDataSet, "$obsNumber <- 1:nrow(", .activeDataSet, ")", sep="")
178
justDoIt(command)
179
logger(command)
180
}
181
}
182
activeDataSet(.activeDataSet, flushModel=FALSE)
183
tkfocus(CommanderWindow())
184
}
185
OKCancelHelp(helpSubject="influence.measures")
186
tkgrid(selectFrame, sticky="w")
187
tkgrid(buttonsFrame, sticky="w")
188
dialogSuffix(rows=5, columns=1)
189
}
190
191
residualQQPlot <- function(){
192
require("car")
193
.activeModel <- ActiveModel()
194
if (is.null(.activeModel) || !checkMethod("qq.plot", .activeModel)) return()
195
initializeDialog(title=gettextRcmdr("Residual Quantile-Comparison Plot"))
196
selectFrame <- tkframe(top)
197
simulateVar <- tclVar("1")
198
identifyVar <- tclVar("0")
199
simulateCheckBox <- tkcheckbutton(selectFrame, variable=simulateVar)
200
identifyCheckBox <- tkcheckbutton(selectFrame, variable=identifyVar)
201
onOK <- function(){
202
closeDialog()
203
simulate <- tclvalue(simulateVar) == 1
204
identify <- if (tclvalue(identifyVar) == 1) paste("names(residuals(", .activeModel, "))",
205
sep="") else "FALSE"
206
command <- paste("qq.plot(", .activeModel, ", simulate=", simulate, ", labels=", identify,
207
")", sep="")
208
doItAndPrint(command)
209
activateMenus()
210
tkfocus(CommanderWindow())
211
}
212
OKCancelHelp(helpSubject="qq.plot.lm")
213
tkgrid(tklabel(selectFrame, text=gettextRcmdr("Simulated confidence envelope")), simulateCheckBox, sticky="w")
214
tkgrid(tklabel(selectFrame, text=gettextRcmdr("Identify points with mouse")), identifyCheckBox, sticky="w")
215
tkgrid(selectFrame, sticky="w")
216
tkgrid(buttonsFrame, sticky="w")
217
dialogSuffix(rows=2, columns=1)
218
}
219
220
testLinearHypothesis <- function(){
221
require("car")
222
.activeModel <- ActiveModel()
223
if (is.null(.activeModel) || !checkMethod("linear.hypothesis", .activeModel)) return()
224
env <- environment()
225
initializeDialog(title=gettextRcmdr("Test Linear Hypothesis"))
226
outerTableFrame <- tkframe(top)
227
assign(".tableFrame", tkframe(outerTableFrame), envir=env)
228
setUpTable <- function(...){
229
tkdestroy(get(".tableFrame", envir=env))
230
assign(".tableFrame", tkframe(outerTableFrame), envir=env)
231
nrows <- as.numeric(tclvalue(rowsValue))
232
col.names <- eval(parse(text=paste("names(coef(", .activeModel, "))")))
233
col.names <- substring(paste(abbreviate(col.names, 12), " "), 1, 12)
234
make.col.names <- "tklabel(.tableFrame, text='')"
235
for (j in 1:ncols) {
236
make.col.names <- paste(make.col.names, ", ",
237
"tklabel(.tableFrame, text='", col.names[j], "')", sep="")
238
}
239
rhsText <- gettextRcmdr("Right-hand side")
240
make.col.names <- paste(make.col.names, ", tklabel(.tableFrame, text=' ')",
241
", tklabel(.tableFrame, text='", rhsText, "')", sep="")
242
eval(parse(text=paste("tkgrid(", make.col.names, ")", sep="")), envir=env)
243
for (i in 1:nrows){
244
varname <- paste(".tab.", i, ".1", sep="")
245
rhs.name <- paste(".rhs.", i, sep="")
246
assign(varname, tclVar("0") , envir=env)
247
assign(rhs.name, tclVar("0"), envir=env)
248
make.row <- paste("tklabel(.tableFrame, text=", i, ")")
249
make.row <- paste(make.row, ", ", "tkentry(.tableFrame, width='5', textvariable=",
250
varname, ")", sep="")
251
for (j in 2:ncols){
252
varname <- paste(".tab.", i, ".", j, sep="")
253
assign(varname, tclVar("0"), envir=env)
254
make.row <- paste(make.row, ", ", "tkentry(.tableFrame, width='5', textvariable=",
255
varname, ")", sep="")
256
}
257
make.row <- paste(make.row, ", tklabel(.tableFrame, text=' '),",
258
"tkentry(.tableFrame, width='5', textvariable=", rhs.name, ")", sep="")
259
eval(parse(text=paste("tkgrid(", make.row, ")", sep="")), envir=env)
260
}
261
tkgrid(get(".tableFrame", envir=env), sticky="w")
262
}
263
ncols <- eval(parse(text=paste("length(coef(", .activeModel, "))")))
264
rowsFrame <- tkframe(top)
265
rowsValue <- tclVar("1")
266
rowsSlider <- tkscale(rowsFrame, from=1, to=ncols, showvalue=FALSE, variable=rowsValue,
267
resolution=1, orient="horizontal", command=setUpTable)
268
rowsShow <- tklabel(rowsFrame, textvariable=rowsValue, width=2, justify="right")
269
onOK <- function(){
270
nrows <- as.numeric(tclvalue(rowsValue))
271
cell <- 0
272
values <- rep(NA, nrows*ncols)
273
rhs <- rep(NA, nrows)
274
for (i in 1:nrows){
275
rhs.name <- paste(".rhs.", i, sep="")
276
rhs[i] <- as.numeric(eval(parse(text=paste("tclvalue(", rhs.name,")", sep=""))))
277
for (j in 1:ncols){
278
cell <- cell+1
279
varname <- paste(".tab.", i, ".", j, sep="")
280
values[cell] <- as.numeric(eval(parse(text=paste("tclvalue(", varname,")", sep=""))))
281
}
282
}
283
values <- na.omit(values)
284
closeDialog()
285
if (length(values) != nrows*ncols){
286
Message(message=sprintf(gettextRcmdr("Number of valid entries in hypothesis matrix(%d)\nnot equal to number of rows (%d) * number of columns (%d)."),
287
length(values), nrows, ncols), type="error")
288
testLinearHypothesis()
289
return()
290
}
291
if (qr(matrix(values, nrows, ncols, byrow=TRUE))$rank < nrows) {
292
Message(message=gettextRcmdr("Hypothesis matrix is not of full row rank."),
293
type="error")
294
testLinearHypothesis()
295
return()
296
}
297
rhs <- na.omit(rhs)
298
if (length(rhs) != nrows){
299
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))
300
return()
301
}
302
command <- paste("matrix(c(", paste(values, collapse=","), "), ", nrows, ", ", ncols,
303
", byrow=TRUE)", sep="")
304
assign(".Hypothesis", justDoIt(command), envir=.GlobalEnv)
305
logger(paste(".Hypothesis <- ", command, sep=""))
306
command <- paste("c(", paste(rhs, collapse=","), ")", sep="")
307
assign(".RHS", justDoIt(command), envir=.GlobalEnv)
308
logger(paste(".RHS <- ", command, sep=""))
309
command <- paste("linear.hypothesis(", .activeModel, ", .Hypothesis, rhs=.RHS)", sep="")
310
doItAndPrint(command)
311
justDoIt("remove(.Hypothesis, .RHS, envir=.GlobalEnv)")
312
logger("remove(.Hypothesis, .RHS)")
313
tkfocus(CommanderWindow())
314
}
315
OKCancelHelp(helpSubject="linear.hypothesis")
316
tkgrid(tklabel(rowsFrame, text=gettextRcmdr("Number of Rows:")), rowsSlider, rowsShow, sticky="w")
317
tkgrid(rowsFrame, sticky="w")
318
tkgrid(tklabel(top, text=gettextRcmdr("Enter hypothesis matrix and right-hand side vector:"), fg="blue"), sticky="w")
319
tkgrid(outerTableFrame, sticky="w")
320
tkgrid(tklabel(top, text=""))
321
tkgrid(buttonsFrame, sticky="w")
322
dialogSuffix(rows=4, columns=1)
323
}
324
325
compareModels <- function(){
326
models <- listAllModels()
327
if (length(models) < 2){
328
Message(message=gettextRcmdr("There are fewer than two models."),
329
type="error")
330
tkfocus(CommanderWindow())
331
return()
332
}
333
initializeDialog(title=gettextRcmdr("Compare Models"))
334
modelsBox1 <- variableListBox(top, models, title=gettextRcmdr("First model (pick one)"))
335
modelsBox2 <- variableListBox(top, models, title=gettextRcmdr("Second model (pick one)"))
336
onOK <- function(){
337
model1 <- getSelection(modelsBox1)
338
model2 <- getSelection(modelsBox2)
339
closeDialog()
340
if (length(model1) == 0 || length(model2) == 0) {
341
errorCondition(recall=compareModels, message=gettextRcmdr("You must select two models."))
342
return()
343
}
344
if (!checkMethod("anova", model1)) {
345
return()
346
}
347
if (!eval(parse(text=paste("class(", model1, ")[1] == class(", model2, ")[1]",
348
sep="")), envir=.GlobalEnv)){
349
Message(message=gettextRcmdr("Models are not of the same class."),
350
type="error")
351
compareModels()
352
return()
353
}
354
doItAndPrint(paste("anova(", model1, ",", model2, ")", sep=""))
355
tkfocus(CommanderWindow())
356
}
357
OKCancelHelp(helpSubject="anova")
358
tkgrid(getFrame(modelsBox1), getFrame(modelsBox2), sticky="nw")
359
tkgrid(buttonsFrame, columnspan=2, sticky="w")
360
dialogSuffix(rows=2, columns=2)
361
}
362
363
BreuschPaganTest <- function(){
364
if (is.null(.activeModel)) return()
365
require("lmtest")
366
initializeDialog(title=gettextRcmdr("Breusch-Pagan Test"))
367
tkgrid(tklabel(top, text=gettextRcmdr("Score Test for Nonconstant Error Variance"), fg="blue"), sticky="w")
368
optionsFrame <- tkframe(top)
369
onOK <- function(){
370
.activeModel <- ActiveModel()
371
var <- tclvalue(varVariable)
372
closeDialog()
373
type <- if (var == "fitted") paste(", varformula = ~ fitted.values(",
374
.activeModel, ")", sep="")
375
else if (var == "predictors") ""
376
else paste(", varformula = ~", tclvalue(rhsVariable), sep="")
377
student <- if (tclvalue(studentVariable) == 1) "TRUE" else "FALSE"
378
model.formula <- as.character(eval(parse(text=paste("formula(", .activeModel, ")", sep=""))))
379
model.formula <- paste(model.formula[2], "~", model.formula[3])
380
command <- paste("bptest(", model.formula, type, ", studentize=", student,
381
", data=", ActiveDataSet(), ")", sep="")
382
doItAndPrint(command)
383
tkfocus(CommanderWindow())
384
}
385
OKCancelHelp(helpSubject="bptest")
386
studentVariable <- tclVar("0")
387
studentFrame <- tkframe(optionsFrame)
388
studentCheckBox <- tkcheckbutton(studentFrame, variable=studentVariable)
389
tkgrid(tklabel(studentFrame, text=gettextRcmdr("Studentized test statistic"), justify="left"),
390
studentCheckBox, sticky="w")
391
tkgrid(studentFrame, sticky="w")
392
radioButtons(optionsFrame, name="var", buttons=c("fitted", "predictors", "other"),
393
labels=gettextRcmdr(c("Fitted values", "Explanatory variables", "Other (specify)")), title=gettextRcmdr("Variance Formula"))
394
tkgrid(varFrame, sticky="w")
395
modelFormula(optionsFrame, hasLhs=FALSE)
396
tkgrid(formulaFrame, sticky="w")
397
tkgrid(outerOperatorsFrame)
398
tkgrid(getFrame(xBox), sticky="w")
399
tkgrid(optionsFrame, sticky="w")
400
tkgrid(buttonsFrame, sticky="w")
401
dialogSuffix(rows=4, columns=1)
402
}
403
404
DurbinWatsonTest <- function(){
405
if (is.null(.activeModel)) return()
406
require("lmtest")
407
initializeDialog(title=gettextRcmdr("Durbin-Waton Test"))
408
tkgrid(tklabel(top, text=gettextRcmdr("Test for First-Order Error Autocorrelation"), fg="blue"), sticky="w")
409
onOK <- function(){
410
altHypothesis <- tclvalue(altHypothesisVariable)
411
closeDialog()
412
model.formula <- as.character(eval(parse(text=paste("formula(", ActiveModel(), ")", sep=""))))
413
model.formula <- paste(model.formula[2], "~", model.formula[3])
414
command <- paste("dwtest(", model.formula, ', alternative="', altHypothesis,
415
'", data=', ActiveDataSet(), ')', sep="")
416
doItAndPrint(command)
417
tkfocus(CommanderWindow())
418
}
419
OKCancelHelp(helpSubject="dwtest")
420
radioButtons(name="altHypothesis", buttons=c("greater", "notequal", "less"), values=c("greater", "two.sided", "less"),
421
labels=c("rho > 0", "rho != 0", "rho < 0"), title=gettextRcmdr("Alternative Hypothesis"))
422
tkgrid(altHypothesisFrame, sticky="w")
423
tkgrid(buttonsFrame, sticky="w")
424
dialogSuffix(rows=3, columns=1)
425
}
426
427
RESETtest <- function(){
428
if (is.null(.activeModel)) return()
429
require("lmtest")
430
initializeDialog(title=gettextRcmdr("RESET Test"))
431
tkgrid(tklabel(top, text=gettextRcmdr("Test for Nonlinearity"), fg="blue"), sticky="w")
432
onOK <- function(){
433
type <- tclvalue(typeVariable)
434
square <- tclvalue(squareVariable)
435
cube <- tclvalue(cubeVariable)
436
closeDialog()
437
model.formula <- as.character(eval(parse(text=paste("formula(", ActiveModel(), ")", sep=""))))
438
model.formula <- paste(model.formula[2], "~", model.formula[3])
439
if (square == "0" && cube == "0"){
440
errorCondition(recall=RESETtest, message=gettextRcmdr("No powers are checked."))
441
return()
442
}
443
powers <- if (square == "1" && cube == "1") "2:3"
444
else if (square == "1" && cube == "0") "2"
445
else if (square == "0" && cube == "1") "3"
446
command <- paste("resettest(", model.formula, ", power=", powers,
447
', type="', type, '", data=', ActiveDataSet(), ')', sep="")
448
doItAndPrint(command)
449
tkfocus(CommanderWindow())
450
}
451
OKCancelHelp(helpSubject="reset")
452
optionsFrame <- tkframe(top)
453
squareVariable <- tclVar("1")
454
squareCheckBox <- tkcheckbutton(optionsFrame, variable=squareVariable)
455
cubeVariable <- tclVar("1")
456
cubeCheckBox <- tkcheckbutton(optionsFrame, variable=cubeVariable)
457
typeVariable <- tclVar("regressor")
458
radioButtons(optionsFrame, name="type", buttons=c("regressor", "fitted", "princomp"),
459
labels=gettextRcmdr(c("Explanatory variables", "Fitted values", "First principal component")),
460
title=gettextRcmdr("Type of Test"))
461
tkgrid(tklabel(optionsFrame, text=gettextRcmdr("Powers to Include"), fg="blue"), sticky="w")
462
tkgrid(tklabel(optionsFrame, text=gettextRcmdr("2 (squares)")), squareCheckBox, sticky="w")
463
tkgrid(tklabel(optionsFrame, text=gettextRcmdr("3 (cubes) ")), cubeCheckBox, sticky="w")
464
tkgrid(typeFrame, sticky="w")
465
tkgrid(optionsFrame, sticky="w")
466
tkgrid(buttonsFrame, sticky="w")
467
dialogSuffix(rows=3, columns=1)
468
}
469
470
outlierTest <- function(){
471
if (is.null(.activeModel)) return()
472
require("car")
473
.activeModel <- ActiveModel()
474
if (!checkMethod("outlier.test", .activeModel)) {
475
errorCondition(gettextRcmdr("There is no appropriate outlier.test method for a model of this class."))
476
return()
477
}
478
doItAndPrint(paste("outlier.test(", .activeModel, ")", sep=""))
479
}
480
481
confidenceIntervals <- function(){
482
if (is.null(.activeModel)) return()
483
require(MASS)
484
initializeDialog(title=gettextRcmdr("Confidence Intervals"))
485
tkgrid(tklabel(top, text=gettextRcmdr("Confidence Intervals for Individual Coefficients"), fg="blue"), sticky="w")
486
onOK <- function(){
487
level <- tclvalue(confidenceLevel)
488
opts <- options(warn=-1)
489
lev <- as.numeric(level)
490
options(opts)
491
closeDialog()
492
if ((is.na(lev)) || (lev < 0) || (lev > 1)) {
493
Message(gettextRcmdr("Confidence level must be a number between 0 and 1."))
494
tkfocus(CommanderWindow())
495
return()
496
}
497
command <- if (glm) paste("Confint(", .activeModel, ", level=", level,
498
', type="', tclvalue(typeVariable), '")', sep="")
499
else paste("Confint(", .activeModel, ", level=", level, ")", sep="")
500
doItAndPrint(command)
501
tkfocus(CommanderWindow())
502
}
503
OKCancelHelp(helpSubject="Confint")
504
confidenceFrame <- tkframe(top)
505
confidenceLevel <- tclVar(".95")
506
confidenceField <- tkentry(confidenceFrame, width="6", textvariable=confidenceLevel)
507
radioButtons(top, name="type", buttons=c("LR", "Wald"),
508
labels=gettextRcmdr(c("Likelihood-ratio statistic", "Wald statistic")), title=gettextRcmdr("Test Based On"))
509
tkgrid(tklabel(confidenceFrame, text=gettextRcmdr("Confidence Level: ")), confidenceField, sticky="w")
510
tkgrid(confidenceFrame, sticky="w")
511
.activeModel <- ActiveModel()
512
glm <- eval(parse(text=paste("class(", .activeModel, ")")))[1] == "glm"
513
if (glm) tkgrid(typeFrame, sticky="w")
514
tkgrid(buttonsFrame, sticky="w")
515
dialogSuffix(rows=3 + glm, columns=1)
516
}
517
1
# Model menu dialogs
2
3
# last modified 26 March 2008 by J. Fox
4
5
selectActiveModel <- function(){
6
models <- listAllModels()
7
.activeModel <- ActiveModel()
8
if ((length(models) == 1) && !is.null(.activeModel)) {
9
Message(message=gettextRcmdr("There is only one model in memory."),
10
type="warning")
11
tkfocus(CommanderWindow())
12
return()
13
}
14
if (length(models) == 0){
15
Message(message=gettextRcmdr("There are no models from which to choose."),
16
type="error")
17
tkfocus(CommanderWindow())
18
return()
19
}
20
initializeDialog(title=gettextRcmdr("Select Model"))
21
.activeDataSet <- ActiveDataSet()
22
initial <- if (is.null(.activeModel)) NULL else which(.activeModel == models) - 1
23
modelsBox <- variableListBox(top, models, title=gettextRcmdr("Models (pick one)"),
24
initialSelection=initial)
25
onOK <- function(){
26
model <- getSelection(modelsBox)
27
closeDialog()
28
if (length(model) == 0) {
29
tkfocus(CommanderWindow())
30
return()
31
}
32
dataSet <- as.character(get(model)$call$data)
33
# dataSet <- eval(parse(text=paste("as.character(", model, "$call$data)")))
34
if (length(dataSet) == 0){
35
errorCondition(message=gettextRcmdr("There is no dataset associated with this model."))
36
return()
37
}
38
dataSets <- listDataSets()
39
if (!is.element(dataSet, dataSets)){
40
errorCondition(message=sprintf(gettextRcmdr("The dataset associated with this model, %s, is not in memory."), dataSet))
41
return()
42
}
43
if (is.null(.activeDataSet) || (dataSet != .activeDataSet)) activeDataSet(dataSet)
44
activeModel(model)
45
tkfocus(CommanderWindow())
46
}
47
OKCancelHelp()
48
nameFrame <- tkframe(top)
49
tkgrid(labelRcmdr(nameFrame, fg="blue", text=gettextRcmdr("Current Model: ")),
50
labelRcmdr(nameFrame, text=tclvalue(getRcmdr("modelName"))), sticky="w")
51
tkgrid(nameFrame, sticky="w", columnspan="2")
52
tkgrid(getFrame(modelsBox), columnspan="2", sticky="w")
53
tkgrid(buttonsFrame, columnspan=2, sticky="w")
54
dialogSuffix(rows=3, columns=2)
55
}
56
57
summarizeModel <- function(){
58
.activeModel <- ActiveModel()
59
if (is.null(.activeModel) || !checkMethod("summary", .activeModel)) return()
60
doItAndPrint(paste("summary(", .activeModel, ", cor=FALSE)", sep=""))
61
}
62
63
plotModel <- function(){
64
.activeModel <- ActiveModel()
65
if (is.null(.activeModel) || !checkMethod("plot", .activeModel)) return()
66
command <- "oldpar <- par(oma=c(0,0,3,0), mfrow=c(2,2))"
67
justDoIt(command)
68
logger(command)
69
doItAndPrint(paste("plot(", .activeModel, ")", sep=""))
70
command <- "par(oldpar)"
71
justDoIt(command)
72
logger(command)
73
}
74
75
CRPlots <- function(){
76
require("car")
77
.activeModel <- ActiveModel()
78
if (is.null(.activeModel) || !checkMethod("cr.plot", .activeModel)) return()
79
doItAndPrint(paste("cr.plots(", .activeModel, ", ask=FALSE)", sep=""))
80
activateMenus()
81
}
82
83
AVPlots <- function(){
84
require("car")
85
.activeModel <- ActiveModel()
86
if (is.null(.activeModel) || !checkMethod("av.plot", .activeModel)) return()
87
response <- tclvalue(RcmdrTkmessageBox(message=gettextRcmdr("Identify points with mouse?"),
88
icon="question", type="yesno", default="no"))
89
doItAndPrint(paste("av.plots(", .activeModel, ", ask=FALSE, identify.points=",
90
response=="yes", ")", sep=""))
91
activateMenus()
92
}
93
94
anovaTable <- function(){
95
require("car")
96
.activeModel <- ActiveModel()
97
if (is.null(.activeModel)) return()
98
if (!checkMethod("Anova", .activeModel)) {
99
errorCondition(message=gettextRcmdr("There is no appropriate Anova method for a model of this class."))
100
return()
101
}
102
doItAndPrint(paste("Anova(", .activeModel, ")", sep=""))
103
}
104
105
VIF <- function(){
106
require("car")
107
.activeModel <- ActiveModel()
108
if (is.null(.activeModel) || !checkMethod("vif", .activeModel)) return()
109
doItAndPrint(paste("vif(", .activeModel, ")", sep=""))
110
}
111
112
InfluencePlot <- function(){
113
require("car")
114
.activeModel <- ActiveModel()
115
if (is.null(.activeModel) || !checkMethod("influencePlot", .activeModel)) return()
116
response <- tclvalue(RcmdrTkmessageBox(message=gettextRcmdr("Identify points with mouse?"),
117
icon="question", type="yesno", default="no"))
118
labels <- if (response == "no") ", labels=FALSE" else ""
119
doItAndPrint(paste("influencePlot(", .activeModel, labels, ")", sep=""))
120
}
121
122
effectPlots <- function(){
123
require("effects")
124
.activeModel <- ActiveModel()
125
if (is.null(.activeModel) || !checkMethod("effect", .activeModel)) return()
126
doItAndPrint('trellis.device(theme="col.whitebg")')
127
command <- paste("plot(all.effects(", .activeModel, "), ask=FALSE)", sep="")
128
justDoIt(command)
129
logger(command)
130
activateMenus()
131
NULL
132
}
133
134
addObservationStatistics <- function(){
135
if (is.null(.activeModel)) return()
136
addVariable <- function(name){
137
variable <- paste(name, ".", .activeModel, sep="")
138
if (is.element(variable, .variables)) {
139
ans <- checkReplace(variable)
140
if (tclvalue(ans) == "no") return()
141
}
142
command <- paste(name, "(", .activeModel, ")", sep="")
143
justDoIt(paste(.activeDataSet, "$", variable, " <- ", command, sep=""))
144
logger(paste(.activeDataSet, "$", variable, " <- ", command, sep=""))
145
}
146
if (getRcmdr("modelWithSubset")){
147
Message(message=
148
gettextRcmdr("Observation statistics not available\nfor a model fit to a subset of the data."),
149
type="error")
150
tkfocus(.commander)
151
return()
152
}
153
initializeDialog(title=gettextRcmdr("Add Observation Statistics to Data"))
154
.activeModel <- ActiveModel()
155
.activeDataSet <- ActiveDataSet()
156
.variables <- Variables()
157
obsNumberExists <- is.element("obsNumber", .variables)
158
activate <- c( checkMethod("fitted", .activeModel, default=TRUE, reportError=FALSE),
159
checkMethod("residuals", .activeModel, default=TRUE, reportError=FALSE),
160
checkMethod("rstudent", .activeModel, reportError=FALSE),
161
checkMethod("hatvalues", .activeModel, reportError=FALSE),
162
checkMethod("cooks.distance", .activeModel, reportError=FALSE))
163
checkBoxes(frame="selectFrame", boxes=c(c("fitted", "residuals", "rstudent", "hatvalues", "cookd")[activate],
164
"obsNumbers"),
165
initialValues=c(rep(1, sum(activate)), if(obsNumberExists) "0" else "1"),
166
labels=c(gettextRcmdr(c("Fitted values", "Residuals", "Studentized residuals", "Hat-values", "Cook's distances"))[activate],
167
gettextRcmdr("Observation indices")))
168
onOK <- function(){
169
closeDialog()
170
if (activate[1] && tclvalue(fittedVariable) == 1) addVariable("fitted")
171
if (activate[2] && tclvalue(residualsVariable) == 1) addVariable("residuals")
172
if (activate[3] && tclvalue(rstudentVariable) == 1) addVariable("rstudent")
173
if (activate[4] && tclvalue(hatvaluesVariable) == 1) addVariable("hatvalues")
174
if (activate[5] && tclvalue(cookdVariable) == 1) addVariable("cooks.distance")
175
if (tclvalue(obsNumbersVariable) == 1){
176
proceed <- if (obsNumberExists) tclvalue(checkReplace("obsNumber")) else "yes"
177
if (proceed == "yes") {
178
command <- paste(.activeDataSet, "$obsNumber <- 1:nrow(", .activeDataSet, ")", sep="")
179
justDoIt(command)
180
logger(command)
181
}
182
}
183
activeDataSet(.activeDataSet, flushModel=FALSE)
184
tkfocus(CommanderWindow())
185
}
186
OKCancelHelp(helpSubject="influence.measures")
187
tkgrid(selectFrame, sticky="w")
188
tkgrid(buttonsFrame, sticky="w")
189
dialogSuffix(rows=5, columns=1)
190
}
191
192
residualQQPlot <- function(){
193
require("car")
194
.activeModel <- ActiveModel()
195
if (is.null(.activeModel) || !checkMethod("qq.plot", .activeModel)) return()
196
initializeDialog(title=gettextRcmdr("Residual Quantile-Comparison Plot"))
197
selectFrame <- tkframe(top)
198
simulateVar <- tclVar("1")
199
identifyVar <- tclVar("0")
200
simulateCheckBox <- tkcheckbutton(selectFrame, variable=simulateVar)
201
identifyCheckBox <- tkcheckbutton(selectFrame, variable=identifyVar)
202
onOK <- function(){
203
closeDialog()
204
simulate <- tclvalue(simulateVar) == 1
205
identify <- if (tclvalue(identifyVar) == 1) paste("names(residuals(", .activeModel, "))",
206
sep="") else "FALSE"
207
command <- paste("qq.plot(", .activeModel, ", simulate=", simulate, ", labels=", identify,
208
")", sep="")
209
doItAndPrint(command)
210
activateMenus()
211
tkfocus(CommanderWindow())
212
}
213
OKCancelHelp(helpSubject="qq.plot.lm")
214
tkgrid(labelRcmdr(selectFrame, text=gettextRcmdr("Simulated confidence envelope")), simulateCheckBox, sticky="w")
215
tkgrid(labelRcmdr(selectFrame, text=gettextRcmdr("Identify points with mouse")), identifyCheckBox, sticky="w")
216
tkgrid(selectFrame, sticky="w")
217
tkgrid(buttonsFrame, sticky="w")
218
dialogSuffix(rows=2, columns=1)
219
}
220
221
testLinearHypothesis <- function(){
222
require("car")
223
.activeModel <- ActiveModel()
224
if (is.null(.activeModel) || !checkMethod("linear.hypothesis", .activeModel)) return()
225
env <- environment()
226
initializeDialog(title=gettextRcmdr("Test Linear Hypothesis"))
227
outerTableFrame <- tkframe(top)
228
assign(".tableFrame", tkframe(outerTableFrame), envir=env)
229
setUpTable <- function(...){
230
tkdestroy(get(".tableFrame", envir=env))
231
assign(".tableFrame", tkframe(outerTableFrame), envir=env)
232
nrows <- as.numeric(tclvalue(rowsValue))
233
col.names <- names(coef(get(.activeModel)))
234
# col.names <- eval(parse(text=paste("names(coef(", .activeModel, "))")))
235
col.names <- substring(paste(abbreviate(col.names, 12), " "), 1, 12)
236
make.col.names <- "labelRcmdr(.tableFrame, text='')"
237
for (j in 1:ncols) {
238
make.col.names <- paste(make.col.names, ", ",
239
"labelRcmdr(.tableFrame, text='", col.names[j], "')", sep="")
240
}
241
rhsText <- gettextRcmdr("Right-hand side")
242
make.col.names <- paste(make.col.names, ", labelRcmdr(.tableFrame, text=' ')",
243
", labelRcmdr(.tableFrame, text='", rhsText, "')", sep="")
244
eval(parse(text=paste("tkgrid(", make.col.names, ")", sep="")), envir=env)
245
for (i in 1:nrows){
246
varname <- paste(".tab.", i, ".1", sep="")
247
rhs.name <- paste(".rhs.", i, sep="")
248
assign(varname, tclVar("0") , envir=env)
249
assign(rhs.name, tclVar("0"), envir=env)
250
make.row <- paste("labelRcmdr(.tableFrame, text=", i, ")")
251
make.row <- paste(make.row, ", ", "ttkentry(.tableFrame, width='5', textvariable=",
252
varname, ")", sep="")
253
for (j in 2:ncols){
254
varname <- paste(".tab.", i, ".", j, sep="")
255
assign(varname, tclVar("0"), envir=env)
256
make.row <- paste(make.row, ", ", "ttkentry(.tableFrame, width='5', textvariable=",
257
varname, ")", sep="")
258
}
259
make.row <- paste(make.row, ", labelRcmdr(.tableFrame, text=' '),",
260
"ttkentry(.tableFrame, width='5', textvariable=", rhs.name, ")", sep="")
261
eval(parse(text=paste("tkgrid(", make.row, ")", sep="")), envir=env)
262
}
263
tkgrid(get(".tableFrame", envir=env), sticky="w")
264
}
265
ncols <- length(coef(get(.activeModel)))
266
# ncols <- eval(parse(text=paste("length(coef(", .activeModel, "))")))
267
rowsFrame <- tkframe(top)
268
rowsValue <- tclVar("1")
269
rowsSlider <- tkscale(rowsFrame, from=1, to=ncols, showvalue=FALSE, variable=rowsValue,
270
resolution=1, orient="horizontal", command=setUpTable)
271
rowsShow <- labelRcmdr(rowsFrame, textvariable=rowsValue, width=2, justify="right")
272
onOK <- function(){
273
nrows <- as.numeric(tclvalue(rowsValue))
274
cell <- 0
275
values <- rep(NA, nrows*ncols)
276
rhs <- rep(NA, nrows)
277
for (i in 1:nrows){
278
rhs.name <- paste(".rhs.", i, sep="")
279
rhs[i] <- as.numeric(eval(parse(text=paste("tclvalue(", rhs.name,")", sep=""))))
280
for (j in 1:ncols){
281
cell <- cell+1
282
varname <- paste(".tab.", i, ".", j, sep="")
283
values[cell] <- as.numeric(eval(parse(text=paste("tclvalue(", varname,")", sep=""))))
284
}
285
}
286
values <- na.omit(values)
287
closeDialog()
288
if (length(values) != nrows*ncols){
289
Message(message=sprintf(gettextRcmdr("Number of valid entries in hypothesis matrix(%d)\nnot equal to number of rows (%d) * number of columns (%d)."),
290
length(values), nrows, ncols), type="error")
291
testLinearHypothesis()
292
return()
293
}
294
if (qr(matrix(values, nrows, ncols, byrow=TRUE))$rank < nrows) {
295
Message(message=gettextRcmdr("Hypothesis matrix is not of full row rank."),
296
type="error")
297
testLinearHypothesis()
298
return()
299
}
300
rhs <- na.omit(rhs)
301
if (length(rhs) != nrows){
302
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))
303
return()
304
}
305
command <- paste("matrix(c(", paste(values, collapse=","), "), ", nrows, ", ", ncols,
306
", byrow=TRUE)", sep="")
307
assign(".Hypothesis", justDoIt(command), envir=.GlobalEnv)
308
logger(paste(".Hypothesis <- ", command, sep=""))
309
command <- paste("c(", paste(rhs, collapse=","), ")", sep="")
310
assign(".RHS", justDoIt(command), envir=.GlobalEnv)
311
logger(paste(".RHS <- ", command, sep=""))
312
command <- paste("linear.hypothesis(", .activeModel, ", .Hypothesis, rhs=.RHS)", sep="")
313
doItAndPrint(command)
314
justDoIt("remove(.Hypothesis, .RHS, envir=.GlobalEnv)")
315
logger("remove(.Hypothesis, .RHS)")
316
tkfocus(CommanderWindow())
317
}
318
OKCancelHelp(helpSubject="linear.hypothesis")
319
tkgrid(labelRcmdr(rowsFrame, text=gettextRcmdr("Number of Rows:")), rowsSlider, rowsShow, sticky="w")
320
tkgrid(rowsFrame, sticky="w")
321
tkgrid(labelRcmdr(top, text=gettextRcmdr("Enter hypothesis matrix and right-hand side vector:"), fg="blue"), sticky="w")
322
tkgrid(outerTableFrame, sticky="w")
323
tkgrid(labelRcmdr(top, text=""))
324
tkgrid(buttonsFrame, sticky="w")
325
dialogSuffix(rows=4, columns=1)
326
}
327
328
compareModels <- function(){
329
models <- listAllModels()
330
if (length(models) < 2){
331
Message(message=gettextRcmdr("There are fewer than two models."),
332
type="error")
333
tkfocus(CommanderWindow())
334
return()
335
}
336
initializeDialog(title=gettextRcmdr("Compare Models"))
337
modelsBox1 <- variableListBox(top, models, title=gettextRcmdr("First model (pick one)"))
338
modelsBox2 <- variableListBox(top, models, title=gettextRcmdr("Second model (pick one)"))
339
onOK <- function(){
340
model1 <- getSelection(modelsBox1)
341
model2 <- getSelection(modelsBox2)
342
closeDialog()
343
if (length(model1) == 0 || length(model2) == 0) {
344
errorCondition(recall=compareModels, message=gettextRcmdr("You must select two models."))
345
return()
346
}
347
if (!checkMethod("anova", model1)) {
348
return()
349
}
350
if (!class(get(model1, envir=.GlobalEnv))[1] == class(get(model2, envir=.GlobalEnv))[1]){
351
# if (!eval(parse(text=paste("class(", model1, ")[1] == class(", model2, ")[1]",
352
# sep="")), envir=.GlobalEnv)){
353
Message(message=gettextRcmdr("Models are not of the same class."),
354
type="error")
355
compareModels()
356
return()
357
}
358
doItAndPrint(paste("anova(", model1, ",", model2, ")", sep=""))
359
tkfocus(CommanderWindow())
360
}
361
OKCancelHelp(helpSubject="anova")
362
tkgrid(getFrame(modelsBox1), getFrame(modelsBox2), sticky="nw")
363
tkgrid(buttonsFrame, columnspan=2, sticky="w")
364
dialogSuffix(rows=2, columns=2)
365
}
366
367
BreuschPaganTest <- function(){
368
if (is.null(.activeModel)) return()
369
require("lmtest")
370
initializeDialog(title=gettextRcmdr("Breusch-Pagan Test"))
371
tkgrid(labelRcmdr(top, text=gettextRcmdr("Score Test for Nonconstant Error Variance"), fg="blue"), sticky="w")
372
optionsFrame <- tkframe(top)
373
onOK <- function(){
374
.activeModel <- ActiveModel()
375
var <- tclvalue(varVariable)
376
closeDialog()
377
type <- if (var == "fitted") paste(", varformula = ~ fitted.values(",
378
.activeModel, ")", sep="")
379
else if (var == "predictors") ""
380
else paste(", varformula = ~", tclvalue(rhsVariable), sep="")
381
student <- if (tclvalue(studentVariable) == 1) "TRUE" else "FALSE"
382
model.formula <- as.character(formula(get(.activeModel)))
383
# model.formula <- as.character(eval(parse(text=paste("formula(", .activeModel, ")", sep=""))))
384
model.formula <- paste(model.formula[2], "~", model.formula[3])
385
command <- paste("bptest(", model.formula, type, ", studentize=", student,
386
", data=", ActiveDataSet(), ")", sep="")
387
doItAndPrint(command)
388
tkfocus(CommanderWindow())
389
}
390
OKCancelHelp(helpSubject="bptest")
391
studentVariable <- tclVar("0")
392
studentFrame <- tkframe(optionsFrame)
393
studentCheckBox <- tkcheckbutton(studentFrame, variable=studentVariable)
394
tkgrid(labelRcmdr(studentFrame, text=gettextRcmdr("Studentized test statistic"), justify="left"),
395
studentCheckBox, sticky="w")
396
tkgrid(studentFrame, sticky="w")
397
radioButtons(optionsFrame, name="var", buttons=c("fitted", "predictors", "other"),
398
labels=gettextRcmdr(c("Fitted values", "Explanatory variables", "Other (specify)")), title=gettextRcmdr("Variance Formula"))
399
tkgrid(varFrame, sticky="w")
400
modelFormula(optionsFrame, hasLhs=FALSE)
401
tkgrid(formulaFrame, sticky="w")
402
tkgrid(outerOperatorsFrame)
403
tkgrid(getFrame(xBox), sticky="w")
404
tkgrid(optionsFrame, sticky="w")
405
tkgrid(buttonsFrame, sticky="w")
406
dialogSuffix(rows=4, columns=1)
407
}
408
409
DurbinWatsonTest <- function(){
410
if (is.null(.activeModel)) return()
411
require("lmtest")
412
initializeDialog(title=gettextRcmdr("Durbin-Waton Test"))
413
tkgrid(labelRcmdr(top, text=gettextRcmdr("Test for First-Order Error Autocorrelation"), fg="blue"), sticky="w")
414
onOK <- function(){
415
altHypothesis <- tclvalue(altHypothesisVariable)
416
closeDialog()
417
model.formula <- as.character(formula(get(ActiveModel())))
418
# model.formula <- as.character(eval(parse(text=paste("formula(", ActiveModel(), ")", sep=""))))
419
model.formula <- paste(model.formula[2], "~", model.formula[3])
420
command <- paste("dwtest(", model.formula, ', alternative="', altHypothesis,
421
'", data=', ActiveDataSet(), ')', sep="")
422
doItAndPrint(command)
423
tkfocus(CommanderWindow())
424
}
425
OKCancelHelp(helpSubject="dwtest")
426
radioButtons(name="altHypothesis", buttons=c("greater", "notequal", "less"), values=c("greater", "two.sided", "less"),
427
labels=c("rho > 0", "rho != 0", "rho < 0"), title=gettextRcmdr("Alternative Hypothesis"))
428
tkgrid(altHypothesisFrame, sticky="w")
429
tkgrid(buttonsFrame, sticky="w")
430
dialogSuffix(rows=3, columns=1)
431
}
432
433
RESETtest <- function(){
434
if (is.null(.activeModel)) return()
435
require("lmtest")
436
initializeDialog(title=gettextRcmdr("RESET Test"))
437
tkgrid(labelRcmdr(top, text=gettextRcmdr("Test for Nonlinearity"), fg="blue"), sticky="w")
438
onOK <- function(){
439
type <- tclvalue(typeVariable)
440
square <- tclvalue(squareVariable)
441
cube <- tclvalue(cubeVariable)
442
closeDialog()
443
model.formula <- as.character(formula(get(ActiveModel())))
444
# model.formula <- as.character(eval(parse(text=paste("formula(", ActiveModel(), ")", sep=""))))
445
model.formula <- paste(model.formula[2], "~", model.formula[3])
446
if (square == "0" && cube == "0"){
447
errorCondition(recall=RESETtest, message=gettextRcmdr("No powers are checked."))
448
return()
449
}
450
powers <- if (square == "1" && cube == "1") "2:3"
451
else if (square == "1" && cube == "0") "2"
452
else if (square == "0" && cube == "1") "3"
453
command <- paste("resettest(", model.formula, ", power=", powers,
454
', type="', type, '", data=', ActiveDataSet(), ')', sep="")
455
doItAndPrint(command)
456
tkfocus(CommanderWindow())
457
}
458
OKCancelHelp(helpSubject="reset")
459
optionsFrame <- tkframe(top)
460
squareVariable <- tclVar("1")
461
squareCheckBox <- tkcheckbutton(optionsFrame, variable=squareVariable)
462
cubeVariable <- tclVar("1")
463
cubeCheckBox <- tkcheckbutton(optionsFrame, variable=cubeVariable)
464
typeVariable <- tclVar("regressor")
465
radioButtons(optionsFrame, name="type", buttons=c("regressor", "fitted", "princomp"),
466
labels=gettextRcmdr(c("Explanatory variables", "Fitted values", "First principal component")),
467
title=gettextRcmdr("Type of Test"))
468
tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Powers to Include"), fg="blue"), sticky="w")
469
tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("2 (squares)")), squareCheckBox, sticky="w")
470
tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("3 (cubes) ")), cubeCheckBox, sticky="w")
471
tkgrid(typeFrame, sticky="w")
472
tkgrid(optionsFrame, sticky="w")
473
tkgrid(buttonsFrame, sticky="w")
474
dialogSuffix(rows=3, columns=1)
475
}
476
477
outlierTest <- function(){
478
if (is.null(.activeModel)) return()
479
require("car")
480
.activeModel <- ActiveModel()
481
if (!checkMethod("outlier.test", .activeModel)) {
482
errorCondition(gettextRcmdr("There is no appropriate outlier.test method for a model of this class."))
483
return()
484
}
485
doItAndPrint(paste("outlier.test(", .activeModel, ")", sep=""))
486
}
487
488
confidenceIntervals <- function(){
489
if (is.null(.activeModel)) return()
490
require(MASS)
491
initializeDialog(title=gettextRcmdr("Confidence Intervals"))
492
tkgrid(labelRcmdr(top, text=gettextRcmdr("Confidence Intervals for Individual Coefficients"), fg="blue"), sticky="w")
493
onOK <- function(){
494
level <- tclvalue(confidenceLevel)
495
opts <- options(warn=-1)
496
lev <- as.numeric(level)
497
options(opts)
498
closeDialog()
499
if ((is.na(lev)) || (lev < 0) || (lev > 1)) {
500
Message(gettextRcmdr("Confidence level must be a number between 0 and 1."))
501
tkfocus(CommanderWindow())
502
return()
503
}
504
command <- if (glm) paste("Confint(", .activeModel, ", level=", level,
505
', type="', tclvalue(typeVariable), '")', sep="")
506
else paste("Confint(", .activeModel, ", level=", level, ")", sep="")
507
doItAndPrint(command)
508
tkfocus(CommanderWindow())
509
}
510
OKCancelHelp(helpSubject="Confint")
511
confidenceFrame <- tkframe(top)
512
confidenceLevel <- tclVar(".95")
513
confidenceField <- ttkentry(confidenceFrame, width="6", textvariable=confidenceLevel)
514
radioButtons(top, name="type", buttons=c("LR", "Wald"),
515
labels=gettextRcmdr(c("Likelihood-ratio statistic", "Wald statistic")), title=gettextRcmdr("Test Based On"))
516
tkgrid(labelRcmdr(confidenceFrame, text=gettextRcmdr("Confidence Level: ")), confidenceField, sticky="w")
517
tkgrid(confidenceFrame, sticky="w")
518
.activeModel <- ActiveModel()
519
glm <- class(get(.activeModel))[1] == "glm"
520
# glm <- eval(parse(text=paste("class(", .activeModel, ")")))[1] == "glm"
521
if (glm) tkgrid(typeFrame, sticky="w")
522
tkgrid(buttonsFrame, sticky="w")
523
dialogSuffix(rows=3 + glm, columns=1)
524
}
525
Loggerhead is a web-based interface for Breezy
Version: 2.0.1