Nothing
R/UMB.GUI.Models.R
In RcmdrPlugin.UMB: R Commander Plug-In for statistics at UMB
Defines functions
predictRegressionModel
forwardAdd
backwardDrop
forwardBackward
backwardForward
bestSubsets
discriminantPlot
contrastGUI
contrastGUI2
postHocGUI
mixtureGUI
anova_reg_GUI
PRESS.GUI
addObservationStatisticsUMB
deviance_tests_GUI
invXtXGUI
Documented in
addObservationStatisticsUMB
anova_reg_GUI
backwardDrop
backwardForward
bestSubsets
contrastGUI
contrastGUI2
deviance_tests_GUI
discriminantPlot
forwardAdd
forwardBackward
invXtXGUI
mixtureGUI
postHocGUI
predictRegressionModel
PRESS.GUI
# $Id: UMB.GUI.Models.R 28 2013-11-07 21:31:50Z khliland $
##
## GUI functions for the Model menu
##
## GUI tips
#
# Usual code structure:
# 1. Intitialise window and prepare graphical elements
# 2. onOK function contianing actions to perform
# 2.1 Collect values from GUI
# 2.2 Test if combination of values is usable
# 2.3 Perform main calculations, print, update models/data etc.
# 3. Set up GUI.
# - tkgrid() adds elements. Explicit placement and width/heigth by colum, row, columnspan and rowspan
# - Frames with graphical elements are safer than direct placement of elements due to version conflicts.
# - dialogSuffix() defines the final size of the grid used for elements.
#########################################################
# Prediction for LDA/QDA, PCR/PLSR and linear regression
predictRegressionModel <- function(){
# Boks som tar imot verdiene til alle preditorene, kommaseparert (navnerekkef?lge m? framkomme, f.eks. med formula).
# Konfidensgrad for CI og PI.
.activeModel <- ActiveModel()
model.class <- justDoIt(paste("class(", .activeModel, ")", sep=""))[1]
if(model.class == "mvr"){
initializeDialog(title=gettextRcmdr("Prediction in multivariate regression"))
ff <- justDoIt(paste("fparse(formula(", .activeModel, "))", sep=""))
ncomp <- justDoIt(paste(.activeModel, "$ncomp", sep=""))
} else {
if(model.class == "lda" || model.class == "qda"){
initializeDialog(title=gettextRcmdr("Prediction in discriminant analysis"))
ff <- justDoIt(paste("colnames(", .activeModel, "$means)", sep=""))
} else {
if(model.class == "lm"){
initializeDialog(title=gettextRcmdr("Prediction in linear regression"))
ff <- justDoIt(paste("fparse(formula(", .activeModel, "))", sep=""))
} else {
initializeDialog(title=gettextRcmdr("Prediction in generalized linear model"))
ff <- justDoIt(paste("fparse(formula(", .activeModel, "))", sep=""))
}
}}
n.eff <- length(ff)
effNames <- list()
effFrames <- list()
effs <- list()
for(i in 1:n.eff){
effNames[[i]] <- tclVar('0')
effFrames[[i]] <- tkframe(top)
effs[[i]] <- ttkentry(effFrames[[i]], width="7", textvariable=effNames[[i]])
}
if(model.class == "lm"){
levelName <- tclVar("0.95")
levelFrame <- tkframe(top)
level <- ttkentry(levelFrame, width="5", textvariable=levelName)
extrapFrame <- tkframe(top)
}
if(model.class == "mvr"){
compName <- tclVar(ncomp)
compFrame <- tkframe(top)
comp <- ttkentry(compFrame, width="5", textvariable=compName)
typeFrame <- tkframe(top)
}
onOK <- function(){ # Actions to perform
closeDialog()
the.effs <- list()
for(i in 1:n.eff){
the.effs[[i]] <- tclvalue(effNames[[i]])
}
if(model.class == "lm"){
levs <- tclvalue(levelName)
if(trim.blanks(levs) == gettextRcmdr("")){
errorCondition(recall=predictRegressionModel, message=gettextRcmdr("Please specify confidence level."))
}
}
if(model.class == "mvr"){
the.comps <- tclvalue(compName)
if(trim.blanks(the.comps) == gettextRcmdr("")){
errorCondition(recall=predictRegressionModel, message=gettextRcmdr("Please specify the number of components to use."))
}
the.type <- as.character(tclvalue(typeVariable))
}
doItAndPrint(paste("attach(", ActiveDataSet(), ")", sep=""))
command <- paste("predict(", .activeModel, ", data.frame(", sep="")
for(i in 1:n.eff){
command <- paste(command, "'", ff[[i]], "'", "=", the.effs[[i]], sep="")
if(i<n.eff)
command <- paste(command, ", ", sep="")
}
if(model.class == "mvr"){
command <- paste(command, "), ncomp=", the.comps, ", type='", the.type, "')", sep="")
} else {
if(model.class == "lm"){
command <- gsub("predict(", "predict_CI_PI(", command, fixed=TRUE)
extrap <- tclvalue(extrapVariable)
if(extrap == gettextRcmdr("1")){
command <- paste(command, "), level=", levs, ", xXXx=TRUE)", sep="")
} else {
command <- paste(command, "), level=", levs, ")", sep="")
}
} else {
if(model.class == "glm"){
command <- gsub("predict(", "predict_link_response(", command, fixed=TRUE)
command <- paste(command, "))", sep="")
} else {
command <- paste(command, "))[1:2]", sep="")
}
}
}
doItAndPrint(command)
if(model.class == "lm" && extrap == gettextRcmdr("1")){
doItAndPrint(paste("max(hatvalues(", .activeModel, ")) # h_max", sep=""))}
# if(model.class == "lm"){
# extrap <- tclvalue(extrapVariable)
# if(extrap == gettextRcmdr("1")){
# command <- paste("X.tmp <- model.matrix(",.activeModel, "); x.tmp <- data.frame(", sep="")
# for(i in 1:n.eff){
# command <- paste(command, "'", ff[[i]], "'", "=", the.effs[[i]], sep="")
# if(i<n.eff)
# command <- paste(command, ", ", sep="")
# }
# justDoIt(paste(command, ")", sep=""))
# justDoIt(paste("x.tmp <- cbind('(Intercept)'=1, as.matrix(x.tmp))", sep=""))
# doItAndPrint(paste("xXXx(X.tmp,x.tmp) # h_00", sep=""))
# doItAndPrint(paste("max(hatvalues(", .activeModel, ")) # h_max", sep=""))
# justDoIt("rm(c('X.tmp','x.tmp'))")
# }
# }
doItAndPrint(paste("detach(", ActiveDataSet(), ")", sep=""))
tkfocus(CommanderWindow())
}
# Set up GUI
OKCancelHelp(helpSubject="predict", model=TRUE)
tkgrid(labelRcmdr(top,text='Specify value of explanatory variable(s)', fg="blue"),sticky="w", row=1, column=1, columnspan=max(n.eff,2))
for(i in 1:n.eff){
tkgrid(labelRcmdr(effFrames[[i]],text=gettextRcmdr(ff[i])),sticky="w")
tkgrid(effs[[i]], sticky="w")
tkgrid(effFrames[[i]], row=2, column=i)
}
tkgrid(labelRcmdr(top,text=''),sticky="w", row=3, column=1, columnspan=max(n.eff,2))
n.row <- 4
if(model.class == "lm"){
tkgrid(labelRcmdr(levelFrame, text=gettextRcmdr("Confidence level:")), level, sticky="w")
tkgrid(levelFrame, sticky="n", row=4, column=1, columnspan=max(floor(n.eff/2),1))
checkBoxes(frame="extrapFrame", boxes=c("extrap"), initialValues=c("0"),
labels=gettextRcmdr(c("Detect hidden extrapolation")))
tkgrid(extrapFrame, sticky="n", row=4, column=max(2, ceiling(n.eff/2)), columnspan=n.eff-floor(n.eff/2))
n.row <- 5
}
if(model.class == "mvr"){
tkgrid(labelRcmdr(compFrame, text=gettextRcmdr("Number of components:")), comp, sticky="w")
tkgrid(compFrame, sticky="n", row=4, column=1, columnspan=max(n.eff,2))
radioButtons(name="type", buttons=c("response", "scores"), values=c("response", "scores"), initialValue="response",
labels=gettextRcmdr(c("Response", "Scores")), title=gettextRcmdr("Type of prediction"))
tkgrid(typeFrame, sticky="n", row=5, column=1, columnspan=max(n.eff,2))
n.row <- 6
}
tkgrid(buttonsFrame, stick="s", row=n.row, column=1, columnspan=max(n.eff,2))
tkgrid.configure(helpButton, sticky="se")
dialogSuffix(rows=n.row, columns=max(n.eff,2))
}
###################################
## Stepwise and subset methods
forwardAdd <- function(){
.activeModel <- ActiveModel()
availableTerms <- justDoIt(paste("attr(",.activeModel,"$terms,'term.labels')",sep=""))
initializeDialog(title=gettextRcmdr("Stepwise forward selection"))
# Boks for signifikans ved ny variabel
alphaName <- tclVar("0.2")
alphaFrame <- tkframe(top)
fullFrame <- tkframe(top)
alpha <- ttkentry(alphaFrame, width="10", textvariable=alphaName)
xBox <- variableListBox(top, availableTerms, selectmode="multiple", title=gettextRcmdr("Compulsory variables (pick zero or more)"))
onOK <- function(){ # Actions to perform
x <- getSelection(xBox)
closeDialog()
the.alpha <- tclvalue(alphaName)
if(trim.blanks(the.alpha) == gettextRcmdr("")){
warning('Please specify the alpha level for entering')
}
fullmodel <- tclvalue(fullmodelVariable)
force.in <- 'NULL'
if(length(x)>0){
force.in <- paste("'",paste(x, collapse="+"),"'", sep="")}
command <- paste("forward(", .activeModel, ", alpha=", the.alpha, ", full=",ifelse(fullmodel == gettextRcmdr("1"), 'TRUE', 'FALSE'),", force.in=",force.in,")", sep="")
doItAndPrint(command)
tkfocus(CommanderWindow())
}
# Set up GUI
OKCancelHelp(helpSubject="add", model=TRUE)
tkgrid(labelRcmdr(alphaFrame, text=gettextRcmdr("Alpha to enter:")), alpha, sticky="w")
tkgrid(alphaFrame, sticky="n")
checkBoxes(frame="fullFrame", boxes=c("fullmodel"), initialValues=c("0"),
labels=gettextRcmdr(c("Extended output")))
tkgrid(fullFrame, sticky="n")
tkgrid(getFrame(xBox), sticky = "n")
tkgrid(buttonsFrame, stick="s")
tkgrid.configure(helpButton, sticky="se")
dialogSuffix(rows=3, columns=2)
}
backwardDrop <- function(){
.activeModel <- ActiveModel()
availableTerms <- justDoIt(paste("attr(",.activeModel,"$terms,'term.labels')",sep=""))
initializeDialog(title=gettextRcmdr("Stepwise backward eliminiation"))
# Boks for signifikans ved ny variabel
alphaName <- tclVar("0.2")
alphaFrame <- tkframe(top)
fullFrame <- tkframe(top)
alpha <- ttkentry(alphaFrame, width="10", textvariable=alphaName)
xBox <- variableListBox(top, availableTerms, selectmode="multiple", title=gettextRcmdr("Compulsory variables (pick zero or more)"))
onOK <- function(){ # Actions to perform
x <- getSelection(xBox)
closeDialog()
the.alpha <- tclvalue(alphaName)
if(trim.blanks(the.alpha) == gettextRcmdr("")){
warning('Please specify the alpha level for elimination')
}
fullmodel <- tclvalue(fullmodelVariable)
force.in <- 'NULL'
if(length(x)>0){
force.in <- paste("c('",paste(x, collapse="','"),"')", sep="")}
command <- paste("backward(", .activeModel, ", alpha=", the.alpha, ", full=",ifelse(fullmodel == gettextRcmdr("1"), 'TRUE', 'FALSE'),", force.in=",force.in,")", sep="")
doItAndPrint(command)
tkfocus(CommanderWindow())
}
# Set up GUI
OKCancelHelp(helpSubject="drop", model=TRUE)
tkgrid(labelRcmdr(alphaFrame, text=gettextRcmdr("Alpha to remove:")), alpha, sticky="w")
tkgrid(alphaFrame, sticky="n")
checkBoxes(frame="fullFrame", boxes=c("fullmodel"), initialValues=c("0"),
labels=gettextRcmdr(c("Extended output")))
tkgrid(fullFrame, sticky="n")
tkgrid(getFrame(xBox), sticky = "n")
tkgrid(buttonsFrame, stick="s")
tkgrid.configure(helpButton, sticky="se")
dialogSuffix(rows=3, columns=2)
}
forwardBackward <- function(){
.activeModel <- ActiveModel()
initializeDialog(title=gettextRcmdr("Stepwise forward/backward selection"))
# Boks for signifikans ved ny variabel
alphaName <- tclVar("0.15")
alphaFrame <- tkframe(top)
alpha1Name <- tclVar("0.15")
alpha1Frame <- tkframe(top)
fullFrame <- tkframe(top)
alpha <- ttkentry(alphaFrame, width="10", textvariable=alphaName)
alpha1 <- ttkentry(alpha1Frame, width="10", textvariable=alpha1Name)
onOK <- function(){ # Actions to perform
closeDialog()
the.alpha <- tclvalue(alphaName)
if(trim.blanks(the.alpha) == gettextRcmdr("")){
warning('Please specify the alpha level for entering')
}
the.alpha1 <- tclvalue(alpha1Name)
if(trim.blanks(the.alpha1) == gettextRcmdr("")){
warning('Please specify the alpha level for removing')
}
fullmodel <- tclvalue(fullmodelVariable)
if(fullmodel == gettextRcmdr("1")){
command <- paste("stepWise(", .activeModel, ", alpha.enter=", the.alpha, ", alpha.remove=", the.alpha1, ", full=TRUE)", sep="")
doItAndPrint(command)
} else{
command <- paste("stepWise(", .activeModel, ", alpha.enter=", the.alpha, ", alpha.remove=", the.alpha1, ", full=FALSE)", sep="")
doItAndPrint(command)}
tkfocus(CommanderWindow())
}
# Set up GUI
OKCancelHelp(helpSubject="add", model=TRUE)
tkgrid(labelRcmdr(alphaFrame, text=gettextRcmdr("Alpha to enter:")), alpha, sticky="w")
tkgrid(alphaFrame, sticky="n")
tkgrid(labelRcmdr(alpha1Frame, text=gettextRcmdr("Alpha to remove:")), alpha1, sticky="w")
tkgrid(alpha1Frame, sticky="n")
checkBoxes(frame="fullFrame", boxes=c("fullmodel"), initialValues=c("0"),
labels=gettextRcmdr(c("Extended output")))
tkgrid(fullFrame, sticky="n")
tkgrid(buttonsFrame, stick="s")
tkgrid.configure(helpButton, sticky="se")
dialogSuffix(rows=4, columns=2)
}
backwardForward <- function(){
.activeModel <- ActiveModel()
initializeDialog(title=gettextRcmdr("Stepwise backward/forward selection"))
# Boks for signifikans ved ny variabel
alphaName <- tclVar("0.15")
alphaFrame <- tkframe(top)
alpha1Name <- tclVar("0.15")
alpha1Frame <- tkframe(top)
fullFrame <- tkframe(top)
alpha <- ttkentry(alphaFrame, width="10", textvariable=alphaName)
alpha1 <- ttkentry(alpha1Frame, width="10", textvariable=alpha1Name)
onOK <- function(){ # Actions to perform
closeDialog()
the.alpha <- tclvalue(alphaName)
if(trim.blanks(the.alpha) == gettextRcmdr("")){
warning('Please specify the alpha level for removing')
}
the.alpha1 <- tclvalue(alpha1Name)
if(trim.blanks(the.alpha1) == gettextRcmdr("")){
warning('Please specify the alpha level for entering')
}
fullmodel <- tclvalue(fullmodelVariable)
if(fullmodel == gettextRcmdr("1")){
command <- paste("stepWiseBack(", .activeModel, ", alpha.remove=", the.alpha, ", alpha.enter=", the.alpha1, ", full=TRUE)", sep="")
doItAndPrint(command)}
else{
command <- paste("stepWiseBack(", .activeModel, ", alpha.remove=", the.alpha, ", alpha.enter=", the.alpha1, ", full=FALSE)", sep="")
doItAndPrint(command)}
tkfocus(CommanderWindow())
}
# Set up GUI
OKCancelHelp(helpSubject="drop", model=TRUE)
tkgrid(labelRcmdr(alphaFrame, text=gettextRcmdr("Alpha to remove:")), alpha, sticky="w")
tkgrid(alphaFrame, sticky="n")
tkgrid(labelRcmdr(alpha1Frame, text=gettextRcmdr("Alpha to enter:")), alpha1, sticky="w")
tkgrid(alpha1Frame, sticky="n")
checkBoxes(frame="fullFrame", boxes=c("fullmodel"), initialValues=c("0"),
labels=gettextRcmdr(c("Extended output")))
tkgrid(fullFrame, sticky="n")
tkgrid(buttonsFrame, stick="s")
tkgrid.configure(helpButton, sticky="se")
dialogSuffix(rows=4, columns=2)
}
bestSubsets <- function(){
.activeModel <- ActiveModel()
availableTerms <- justDoIt(paste("attr(",.activeModel,"$terms,'term.labels')",sep=""))
initializeDialog(title=gettextRcmdr("Best subset regression"))
# Bokser for antall
nbestName <- tclVar("3")
nbestFrame <- tkframe(top)
nvmaxName <- tclVar("3")
nvmaxFrame <- tkframe(top)
nbest <- ttkentry(nbestFrame, width="10", textvariable=nbestName)
nvmax <- ttkentry(nvmaxFrame, width="10", textvariable=nvmaxName)
# Valg av faste variabler
xBox <- variableListBox(top, availableTerms, selectmode="multiple", title=gettextRcmdr("Compulsory variables (pick zero or more)"))
onOK <- function(){ # Actions to perform
x <- getSelection(xBox)
closeDialog()
the.nbest <- tclvalue(nbestName)
if(trim.blanks(the.nbest) == gettextRcmdr("")){
warning('Please specify the number of models per model size')
}
the.nvmax <- tclvalue(nvmaxName)
if(trim.blanks(the.nvmax) == gettextRcmdr("")){
warning('Please specify the maximum model size')
}
force.in <- 'NULL'
if(length(x)>0){
force.in <- paste("'c(",paste(is.element(availableTerms,x), collapse=","),")'", sep="")}
command <- paste("best.subsets(", .activeModel, ", nbest=", the.nbest, ", nvmax=", the.nvmax, ", force.in=", force.in,")", sep="")
doItAndPrint(command)
tkfocus(CommanderWindow())
}
# Set up GUI
OKCancelHelp(helpSubject="regsubsets", model=TRUE)
tkgrid(labelRcmdr(nbestFrame, text=gettextRcmdr("Number of models per model size:")), nbest, sticky="w")
tkgrid(nbestFrame, sticky="n")
tkgrid(labelRcmdr(nvmaxFrame, text=gettextRcmdr("Maximum model size:")), nvmax, sticky="w")
tkgrid(nvmaxFrame, sticky="n")
tkgrid(getFrame(xBox), sticky = "n")
tkgrid(buttonsFrame, stick="s")
tkgrid.configure(helpButton, sticky="se")
dialogSuffix(rows=4, columns=2)
}
################################
## 2D discrinimant plot
discriminantPlot <- function(){
initializeDialog(title=gettextRcmdr("Two-dimensional discriminant plot"))
boxFrame <- tkframe(top)
sliderFrame <- tkframe(top)
sliderValue <- tclVar("100")
componentsSlider <- tkscale(sliderFrame, from=50, to=500, showvalue=FALSE, variable=sliderValue,
resolution=50, orient="horizontal")
componentsShow <- labelRcmdr(sliderFrame, textvariable=sliderValue, width=3, justify="right")
onOK <- function(){ # Actions to perform
the.slider <- as.numeric(tclvalue(sliderValue))
closeDialog()
the.regions <- tclvalue(regionsVariable)
the.contours <- tclvalue(contoursVariable)
if(the.regions == gettextRcmdr("1") && the.contours == gettextRcmdr("1")){
command <- paste("plotDA(regions=TRUE, contours=TRUE, resolution=", the.slider, ")", sep="")
}
if(the.regions == gettextRcmdr("0") && the.contours == gettextRcmdr("1")){
command <- paste("plotDA(regions=FALSE, contours=TRUE, resolution=", the.slider, ")", sep="")
}
if(the.regions == gettextRcmdr("1") && the.contours == gettextRcmdr("0")){
command <- paste("plotDA(regions=TRUE, contours=FALSE, resolution=", the.slider, ")", sep="")
}
if(the.regions == gettextRcmdr("0") && the.contours == gettextRcmdr("0")){
command <- paste("plotDA(regions=FALSE, contours=FALSE, resolution=", the.slider, ")", sep="")
}
logger(command)
justDoIt(command)
tkfocus(CommanderWindow())
}
# Set up GUI
OKCancelHelp(helpSubject="plot", model=TRUE)
tkgrid(labelRcmdr(top, text=gettextRcmdr("Plot resolution:"), fg="blue"), sticky="w")
tkgrid(componentsSlider, componentsShow, sticky="nw")
tkgrid(sliderFrame, sticky="w")
checkBoxes(frame="boxFrame", boxes=c("regions","contours"), initialValues=c("1","0"),
labels=gettextRcmdr(c("Show discriminant regions", "Show binormal contours")))
tkgrid(boxFrame, sticky="w")
tkgrid(buttonsFrame, stick="s")
tkgrid.configure(helpButton, sticky="se")
dialogSuffix(rows=5, columns=2)
}
#####################################
# ANOVA contrasts
contrastGUI <- function(){
.activeModel <- ActiveModel()
levs <- justDoIt(paste(.activeModel, "$xlevels", sep=""))
if(length(levs)==0 || length(levs)>2){
return()
}
if(length(levs)>1){
initializeDialog(title=gettextRcmdr("Test contrasts in ANOVA (choose factor)"))
xFrame <- tkframe(top)
xBox <- variableListBox(xFrame, names(levs),
title=gettextRcmdr("Factors (pick one)"))
onOK <- function(){ # Actions to perform
x <- getSelection(xBox)
closeDialog()
if (length(x)==0) {
errorCondition(recall=contrastGUI,
message=gettextRcmdr("No variables selected."))
return()
}
contrastGUI2(which(names(levs)==x),levs)
}
OKCancelHelp(helpSubject="fit.contrast", model=TRUE)
tkgrid(getFrame(xBox), sticky="nw")
tkgrid(xFrame, sticky="w")
tkgrid(buttonsFrame, sticky="w")
tkgrid.configure(helpButton, sticky="se")
dialogSuffix(rows=2, columns=1)
} else{
contrastGUI2(1,levs)
}
}
contrastGUI2 <- function(varNumb,levs){
# Boks som tar imot verdiene til alle prediktorene, kommaseparert (navnerekkef?lge m? framkomme, f.eks. med formula).
# Konfidensgrad for CI og PI.
initializeDialog(title=gettextRcmdr("Test contrasts in ANOVA"))
.activeModel <- ActiveModel()
ff <- justDoIt(paste(.activeModel, "$xlevels[[", varNumb, "]]", sep=""))
fn <- justDoIt(paste("names(", .activeModel, "$xlevels)[[", varNumb, "]]", sep=""))
n.eff <- length(ff)
effNames <- list()
effFrames <- list()
effs <- list()
if(n.eff>2){
for(i in 1:n.eff){
effNames[[i]] <- tclVar('0')
effFrames[[i]] <- tkframe(top)
effs[[i]] <- ttkentry(effFrames[[i]], width=5, textvariable=effNames[[i]])
}
} else{
effNames[[1]] <- tclVar('1')
effNames[[2]] <- tclVar('-1')
effFrames[[1]] <- tkframe(top)
effFrames[[2]] <- tkframe(top)
effs[[1]] <- ttkentry(effFrames[[1]], width=5, textvariable=effNames[[1]])
effs[[2]] <- ttkentry(effFrames[[2]], width=5, textvariable=effNames[[2]])
}
levelName <- tclVar("0.95")
levelFrame <- tkframe(top)
level <- ttkentry(levelFrame, width="10", textvariable=levelName)
onOK <- function(){ # Actions to perform
closeDialog()
effValues <- numeric(n.eff)
for(i in 1:n.eff){
effValues[i] <- try(eval(parse(text=(tclvalue(effNames[[i]])))))
}
if(abs(sum(effValues)) >= 0.1){
errorCondition(recall=contrastGUI2, message=gettextRcmdr("Contrasts must sum to 0 (total deviance allowed=0.1)."))
return()
}
levelValue <- as.numeric(tclvalue(levelName))
if(levelValue <= 0 || levelValue >= 1){
errorCondition(recall=contrastGUI2, message=gettextRcmdr("Confidence level must be >0 and <1."))
return()
}
# level.name <- justDoIt(paste("names(",.activeModel, "$xlevels)", sep=""))
command <- paste("print(fit.contrast(model=", ActiveModel(), ", varname='",fn, "', df=TRUE, coeff=c(", effValues[1], sep="")
for(i in 2:n.eff){
command <- paste(command, ", ", effValues[i], sep="")
}
command <- paste(command, "), conf.int=", levelValue,"))", sep="")
# If interaction, test per level, not across levels
has.interaction <- justDoIt(paste("max(apply(attr(",.activeModel, "$terms,'factors'),1,sum))>1", sep=""))
if(length(levs)>1 && has.interaction){
the.levels <- justDoIt(paste("levels(",ActiveDataSet(),"$",names(levs[3-varNumb]),")",sep=""))
for(i in 1:length(the.levels)){
doItAndPrint(paste(paste("cat('Contrast for ",names(levs[3-varNumb]), " = ", the.levels[1], "\n')", sep=""),command, sep="; "))
# doItAndPrint(command)
the.levels <- c(the.levels[-1],the.levels[1])
doItAndPrint(paste(ActiveDataSet(),"$",names(levs[3-varNumb]), " <- factor(", ActiveDataSet(),"$",names(levs[3-varNumb]), ", levels=c('",paste(the.levels,sep="",collapse="','"),"'))",sep=""))
}
} else {
doItAndPrint(command)
}
#logger(command)
tkfocus(CommanderWindow())
}
# Set up GUI
OKCancelHelp(helpSubject="fit.contrast", model=TRUE)
tkgrid(labelRcmdr(top,text=paste('Specify contrast for ', fn, sep=""), fg="blue"),sticky="w", row=1, column=1, columnspan=n.eff)
for(i in 1:n.eff){
tkgrid(labelRcmdr(effFrames[[i]],text=gettextRcmdr(ff[i])),sticky="w")
tkgrid(effs[[i]], sticky="w")
tkgrid(effFrames[[i]], row=2, column=i)
}
tkgrid(labelRcmdr(top,text=''),sticky="w", row=3, column=1, columnspan=n.eff)
tkgrid(labelRcmdr(levelFrame, text=gettextRcmdr("Confidence level:")), level, sticky="w")
tkgrid(levelFrame, sticky="w", row=4, column=1, columnspan=n.eff)
tkgrid(buttonsFrame, stick="s", row=5, column=1, columnspan=n.eff)
tkgrid.configure(helpButton, sticky="se")
dialogSuffix(rows=5, columns=n.eff)
}
#####################################
# Post hoc tests
postHocGUI <- function(){
initializeDialog(title=gettextRcmdr("Post hoc pair-wise tests"))
.activeModel <- ActiveModel()
effects <- eval(parse(text=paste("attr(terms(formula(",.activeModel,")),'term.labels')", sep="")))
# if(glmP()){
# effects <- effects[!grepl(":",effects)]
# }
xFrame <- tkframe(top)
# if(glmP()){
xBox <- variableListBox(xFrame, effects,
title=gettextRcmdr("Effects (pick one)"))
# } else {
# xBox <- variableListBox(xFrame, effects, selectmode="multiple",
# title=gettextRcmdr("Effects (pick one or more)"))
#}
comboFrame <- tkframe(top)
levs <- justDoIt(paste(.activeModel, "$xlevels", sep=""))
levNames <- names(levs)
values <- NULL
valuesLookUp <- NULL
comboVar <- tclVar()
for(i in 1:length(levNames)){
values <- c(values, paste(levNames[i], levs[[i]], sep=", "))
valuesLookUp <- rbind(valuesLookUp, cbind(rep(levNames[i],length(levs[[i]])),levs[[i]]))
}
onOK <- function(){
x <- getSelection(xBox)
selectedDunnett <- which(values==tclvalue(comboVar))
if(length(x)==0 && length(selectedDunnett)==0){
errorCondition(recall=postHocGUI, message=gettextRcmdr("Pick at least one effect for pair-wise comparisons other than Dunnett."))
return()
}
if(length(x)==1){
selected <- paste("'",x,"'",sep="")
} else {
selected <- paste("c('",paste(x,sep="",collapse="','"),"')", sep="")
}
the.tukey <- tclvalue(tukeyName)
if(tclvalue(tukeyTestsVariable)== gettextRcmdr("1")){
command <- paste("print(simple.glht(", ActiveModel(), ",",selected,", level=", the.tukey,"))",sep="")
# if(glmP()){
# command <- paste("summary(glht(", ActiveModel(), ", linfct=mcp(", x, "='Tukey')))", sep="")
# } else {
# command <- paste("TukeyHSD(", ActiveModel(), ",",selected,", conf.level=",the.tukey,")",sep="")
# }
doItAndPrint(command)
}
if(tclvalue(tukeyGroupsVariable)== gettextRcmdr("1")){
command <- paste("cld(simple.glht(", ActiveModel(), ",",selected,", level=", the.tukey,"))",sep="")
# if(glmP()){
# command <- paste("multcomp:::print.cld(multcomp::cld(glht(", ActiveModel(), ", linfct=mcp(", x, "='Tukey'))))", sep="")
# } else {
# command <- paste("cld(TukeyHSD(", ActiveModel(), ", ", selected, "), ", 1-as.numeric(the.tukey),")", sep="")
# }
doItAndPrint(command)
}
# if(!glmP()){
the.bonferroni <- tclvalue(bonferroniName)
if(tclvalue(bonferroniTestsVariable)== gettextRcmdr("1")){
command <- paste("print(simple.glht(", ActiveModel(), ",",selected,", corr='Bonferroni', level=", the.tukey,"))",sep="")
# command <- paste("Bonferroni(", ActiveModel(), ",",selected,", conf.level=",the.bonferroni,")",sep="")
doItAndPrint(command)
}
if(tclvalue(bonferroniGroupsVariable)== gettextRcmdr("1")){
command <- paste("cld(simple.glht(", ActiveModel(), ",",selected,", corr='Bonferroni', level=", the.tukey,"))",sep="")
doItAndPrint(command)
# doItAndPrint(paste("cld(Bonferroni(", ActiveModel(), ", ", selected, "), ", 1-as.numeric(the.bonferroni), ")", sep=""))
}
the.fisher <- tclvalue(fisherName)
if(tclvalue(fisherTestsVariable)== gettextRcmdr("1")){
command <- paste("print(simple.glht(", ActiveModel(), ",",selected,", corr='Fisher', level=", the.tukey,"))",sep="")
# command <- paste("Fisher(", ActiveModel(), ",",selected,", conf.level=",the.fisher,")",sep="")
doItAndPrint(command)
}
if(tclvalue(fisherGroupsVariable)== gettextRcmdr("1")){
command <- paste("cld(simple.glht(", ActiveModel(), ",",selected,", corr='Fisher', level=", the.tukey,"))",sep="")
doItAndPrint(command)
# doItAndPrint(paste("cld(Fisher(", ActiveModel(), ", ", selected, "), ", 1-as.numeric(the.fisher), ")", sep=""))
}
if(length(selectedDunnett)>0){
effect <- valuesLookUp[selectedDunnett,1]
level <- valuesLookUp[selectedDunnett,2]
command <- paste("levels(", ActiveModel(), "$model[,'", effect, "'])", sep="")
effLevs.orig <- effLevs <- justDoIt(command)
if(effLevs[1]!=level){
effLevs <- c(level, effLevs[!is.element(effLevs,level)])
command <- paste(ActiveDataSet(), "$", effect, " <- factor(", ActiveDataSet(), "$", effect, ", levels=c('", paste(effLevs,sep="", collapse="', '"), "'))", sep="")
doItAndPrint(command)
doItAndPrint(paste(ActiveModel(), " <- update(",ActiveModel(),")",sep=""))
}
command <- paste("summary(glht(", ActiveModel(), ", linfct = mcp(", effect, " = 'Dunnett')))", sep="")
doItAndPrint(command)
if(effLevs.orig[1]!=level){
command <- paste(ActiveDataSet(), "$", effect, " <- factor(", ActiveDataSet(), "$", effect, ", levels=c('", paste(effLevs.orig,sep="", collapse="', '"), "'))", sep="")
doItAndPrint(command)
doItAndPrint(paste(ActiveModel(), " <- update(",ActiveModel(),")",sep=""))
}
}
# }
closeDialog()
return()
}
OKCancelHelp(helpSubject="simple.glht")
tkgrid(getFrame(xBox), sticky="nw")
tkgrid(xFrame, row=1, column=1, columnspan=2, sticky="w")
topFrame <- tkframe(top)
tkgrid(labelRcmdr(topFrame, text=gettextRcmdr("Tukey HSD"), fg="blue"),sticky="w")
tkgrid(topFrame, row=2, column=1, columnspan=1, sticky="w")
checkBoxes(frame="tukeyFrame", boxes=c("tukeyTests","tukeyGroups"), initialValues=c("0","0"),
labels=gettextRcmdr(c("Tests","Groups")))
tkgrid(tukeyFrame, row=3, column=1, columnspan=1, rowspan=1, sticky="w")
tukeyName <- tclVar("0.95")
tukeyFrameGr <- tkframe(top)
tukey <- ttkentry(tukeyFrameGr, width="6", textvariable=tukeyName)
tkgrid(labelRcmdr(tukeyFrameGr, text=gettextRcmdr("Confidence")), tukey, sticky="w")
tkgrid(tukeyFrameGr, sticky="w", row=3, column=2)
# if(!glmP()){
topFrame2 <- tkframe(top)
tkgrid(labelRcmdr(topFrame2, text=gettextRcmdr("Bonferroni"), fg="blue"),sticky="w")
tkgrid(topFrame2, row=4, column=1, columnspan=1, sticky="w")
checkBoxes(frame="bonferroniFrame", boxes=c("bonferroniTests","bonferroniGroups"), initialValues=c("0","0"),
labels=gettextRcmdr(c("Tests","Groups")))
tkgrid(bonferroniFrame, row=5, column=1, columnspan=1, rowspan=1, sticky="w")
bonferroniName <- tclVar("0.95")
bonferroniFrameGr <- tkframe(top)
bonferroni <- ttkentry(bonferroniFrameGr, width="6", textvariable=bonferroniName)
tkgrid(labelRcmdr(bonferroniFrameGr, text=gettextRcmdr("Confidence")), bonferroni, sticky="w")
tkgrid(bonferroniFrameGr, sticky="w", row=5, column=2)
topFrame3 <- tkframe(top)
tkgrid(labelRcmdr(topFrame3, text=gettextRcmdr("Fisher"), fg="blue"),sticky="w")
tkgrid(topFrame3, row=6, column=1, columnspan=1, sticky="w")
checkBoxes(frame="fisherFrame", boxes=c("fisherTests","fisherGroups"), initialValues=c("0","0"),
labels=gettextRcmdr(c("Tests","Groups")))
tkgrid(fisherFrame, row=7, column=1, columnspan=1, rowspan=1, sticky="w")
fisherName <- tclVar("0.95")
fisherFrameGr <- tkframe(top)
fisher <- ttkentry(fisherFrameGr, width="6", textvariable=fisherName)
tkgrid(labelRcmdr(fisherFrameGr, text=gettextRcmdr("Confidence")), fisher, sticky="w")
tkgrid(fisherFrameGr, sticky="w", row=7, column=2)
topFrame1 <- tkframe(top)
tkgrid(labelRcmdr(topFrame1, text=gettextRcmdr("Dunnet"), fg="blue"),sticky="w")
tkgrid(topFrame1, row=8, column=1, columnspan=1, sticky="w")
combo <- ttkcombobox(comboFrame, values=values, textvariable=comboVar)
tkgrid(labelRcmdr(comboFrame, text=gettextRcmdr("Choose comparison:")), combo, sticky="w")
tkgrid(comboFrame, sticky="w", column=1, row=9, columnspan=2)
# }
tkgrid(buttonsFrame, sticky="w", column=1, row=10, columnspan=2)
dialogSuffix(rows=10, columns=2)
}
#####################################
# Plot mixture experiment
mixtureGUI <- function(){
initializeDialog(title=gettextRcmdr("Plot response surface for mixture design"))
.numeric <- Numeric()
comboVar <- tclVar()
comboFrame <- tkframe(top)
comboVar2 <- tclVar()
comboFrame2 <- tkframe(top)
formatFrame <- tkframe(top)
zoomFrame <- tkframe(top)
onOK <- function(){ # Actions to perform
mix.format <- as.character(tclvalue(label.formatVariable))
zoomed <- tclvalue(zoomedVariable)
if(zoomed == gettextRcmdr("1")){
zoomed <- "TRUE"
} else {
zoomed <- "FALSE"
}
show.points <- tclvalue(samplesVariable)
if(show.points == gettextRcmdr("1")){
show.points <- "TRUE"
} else {
show.points <- "FALSE"
}
logen <- ifelse(tclvalue(logVariable)== gettextRcmdr("1"), TRUE, FALSE)
n.ticks <- which(as.character(2:10)==tclvalue(comboVar))+1
if(length(n.ticks)==0) n.ticks <- "6"
n.grade <- which(as.character(seq(5,25,5))==tclvalue(comboVar2))*5
if(length(n.grade)==0) n.grade <- "15"
closeDialog()
.activeDataSet <- ActiveDataSet()
.activeModel <- ActiveModel()
formula1 <- justDoIt(paste("formula(",.activeModel, ")", sep=""))
if(logen){
doItAndPrint(paste("mixture.contour(", .activeDataSet, ", ", paste(formula1[2],formula1[1],formula1[3],sep=" "), ", n.tick=", n.ticks, ", n.grade=", n.grade,", FUN='exp', FUN2='log', mix.format='",mix.format,"', show.points=",show.points,", zoomed=",zoomed,ifelse(show.points,", pch=21, cex=1.25, col.points='black', fill.points='white'",""),")", sep=""))
} else {
doItAndPrint(paste("mixture.contour(", .activeDataSet, ", ", paste(formula1[2],formula1[1],formula1[3],sep=" "), ", n.tick=", n.ticks, ", n.grade=", n.grade,", mix.format='",mix.format,"', show.points=",show.points,", zoomed=",zoomed,ifelse(show.points,", pch=21, cex=1.25, col.points='black', fill.points='white'",""),")", sep=""))
}
tkfocus(CommanderWindow())
}
# Set up GUI
OKCancelHelp(helpSubject="lm")
combo <- ttkcombobox(comboFrame, values=as.character(2:10), textvariable=comboVar, width=3)
combo2 <- ttkcombobox(comboFrame2, values=as.character(seq(5,25,5)), textvariable=comboVar2, width=3)
tkgrid(labelRcmdr(comboFrame, text=gettextRcmdr("Plot ticks (default=6):")), combo, sticky="w")
tkgrid(labelRcmdr(comboFrame2, text=gettextRcmdr("Plot gradings (approximate, default=15):")), combo2, sticky="w")
tkgrid(comboFrame, sticky="w", column=1, row=1, columnspan=1)
tkgrid(comboFrame2, sticky="w", column=1, row=2, columnspan=1)
checkBoxes(frame="logFrame", boxes=c("log"), initialValues=c("0"),
labels=gettextRcmdr(c("log transformed response")))
tkgrid(logFrame, row=3, column=1, columnspan=1, rowspan=1, sticky="w")
radioButtonsUMB(formatFrame,name="label.format", buttons=c("frac", "dec"), values=c("frac", "dec"), initialValue = "frac",
labels=gettextRcmdr(c("Fraction", "Decimal")))
tkgrid(formatFrame, row=4, column=1, columnspan=1, rowspan=1, sticky="w")
checkBoxes(frame="zoomFrame", boxes=c("samples","zoomed"), initialValues=c("0"), labels=gettextRcmdr(c("Show samples", "Zoom on samples")))
tkgrid(zoomFrame, row=5, column=1, columnspan=1, rowspan=1, sticky="w")
tkgrid(buttonsFrame, sticky="w", row=6, column=1, columnspan=1)
dialogSuffix(rows=6, columns=1)
}
#####################################
# ANOVA for regression
anova_reg_GUI <- function(){
doItAndPrint(paste("anova_reg(", ActiveModel(), ")", sep=""))
}
#####################################
# PRESS
PRESS.GUI <- function(){
doItAndPrint(paste("PRESS(", ActiveModel(), ")", sep=""))
doItAndPrint(paste("R2pred(", ActiveModel(), ")", sep=""))
doItAndPrint(paste("RMSEP(", ActiveModel(), ")", sep=""))
}
######################################
## Customized observation statistics
addObservationStatisticsUMB <- function(){
.activeModel <- ActiveModel()
if (is.null(.activeModel)) return()
addVariable <- function(name, type=NULL){
variable <- paste(name, ".", ifelse(is.null(type),"",paste(type,".",sep="")), .activeModel, sep="")
if (is.element(variable, .variables)) {
ans <- checkReplace(variable)
if (tclvalue(ans) == "no") return()
}
command <- paste(name, "(", .activeModel, ifelse(is.null(type),"",paste(", type='",type,"'",sep="")), ")", sep="")
if(is.matrix(justDoIt(command))){
justDoIt(paste(.activeDataSet, " <- cbind(", .activeDataSet ,", extend.colnames(", command,",'", variable, "'))", sep=""))
logger(paste(.activeDataSet, " <- cbind(", .activeDataSet ,", extend.colnames(", command,",'", variable, "'))", sep=""))
} else {
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(.commander)
return()
}
initializeDialog(title=gettextRcmdr("Add Observation Statistics to Data"))
.activeModel <- ActiveModel()
.activeDataSet <- ActiveDataSet()
.variables <- Variables()
obsNumberExists <- is.element("obsNumber", .variables)
activate1 <- c( checkMethod("fitted", .activeModel, default=TRUE, reportError=FALSE),
checkMethod("residuals", .activeModel, default=TRUE, reportError=FALSE))
activate2 <- c( checkMethod("hatvalues", .activeModel, reportError=FALSE),
TRUE, # dffits
checkMethod("cooks.distance", .activeModel, reportError=FALSE))
activate3 <- c( TRUE,TRUE) # stdres, studres
activate4 <- c( TRUE,TRUE) # pearson, spearson
activate5 <- c( TRUE, TRUE) # PRESS.res, PRESS.pred
checkBoxes(frame="selectFrame1", boxes=c(c("fitted", "residuals")[activate1]),
initialValues=c(rep(0, sum(activate1))),
labels=c(gettextRcmdr(c("Fitted values", "Residuals"))[activate1]))
checkBoxes(frame="selectFrame2", boxes=c(c("hatvalues", "dffits", "cookd")[activate2]),
initialValues=c(rep(0, sum(activate2))),
labels=c(gettextRcmdr(c("Hat-values", "DFFITS", "Cook's distances"))[activate2]))
checkBoxes(frame="selectFrame3", boxes=c(c("stdres", "studres")[activate3]),
initialValues=c(rep(0, sum(activate3)), "0"),
labels=c(gettextRcmdr(c("Standardized residuals", "Studentized residuals"))[activate3]))
checkBoxes(frame="selectFrame4", boxes=c(c("pearson", "spearson")[activate4]),
initialValues=c(rep(0, sum(activate4))),
labels=c(gettextRcmdr(c("Pearson residuals", "Standardized Pearson residuals"))[activate4]))
checkBoxes(frame="selectFrame5", boxes=c(c("pressres","presspred")[activate5]),
initialValues=c(rep(0, sum(activate5))),
labels=c(gettextRcmdr(c("CV residual", "CV predictions"))[activate5]))
checkBoxes(frame="selectFrame6", boxes=c("obsNumbers"),
initialValues=c("0"),
labels=c( gettextRcmdr("Observation indices")))
onOK <- function(){
closeDialog()
if (activate1[1] && tclvalue(fittedVariable) == 1) addVariable("fitted")
if (activate1[2] && tclvalue(residualsVariable) == 1) addVariable("residuals")
if (activate3[1] && tclvalue(stdresVariable) == 1) addVariable("stdres")
if (activate3[2] && tclvalue(studresVariable) == 1) addVariable("studres")
if (activate4[1] && tclvalue(pearsonVariable) == 1) addVariable("residuals","pearson")
if (activate4[2] && tclvalue(spearsonVariable) == 1) addVariable("spearson")
if (activate2[1] && tclvalue(hatvaluesVariable) == 1) addVariable("hatvalues")
if (activate2[2] && tclvalue(dffitsVariable) == 1) addVariable("dffits")
if (activate2[3] && tclvalue(cookdVariable) == 1) addVariable("cooks.distance")
if (activate5[1] && tclvalue(pressresVariable) == 1) addVariable("PRESS.res")
if (activate5[2] && tclvalue(presspredVariable) == 1) addVariable("PRESS.pred")
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)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="influence.measures")
tkgrid(selectFrame1, sticky="w", column=1, row=1, rowspan=2)
tkgrid(selectFrame2, sticky="w", column=1, row=4, rowspan=3)
tkgrid(selectFrame3, sticky="w", column=2, row=1, rowspan=2)
tkgrid(selectFrame4, sticky="w", column=2, row=4, rowspan=2)
tkgrid(selectFrame5, sticky="w", column=2, row=7, rowspan=2)
tkgrid(selectFrame6, sticky="w", column=1, row=8, rowspan=1)
spaceFrame1 <- tkframe(top)
tkgrid(labelRcmdr(spaceFrame1, text=gettextRcmdr(" ")), sticky="w")
tkgrid(spaceFrame1, sticky="w", row=3, column=1, columnspan=1)
spaceFrame2 <- tkframe(top)
tkgrid(labelRcmdr(spaceFrame2, text=gettextRcmdr(" ")), sticky="w")
tkgrid(spaceFrame2, sticky="w", row=3, column=2, columnspan=1)
spaceFrame3 <- tkframe(top)
tkgrid(labelRcmdr(spaceFrame3, text=gettextRcmdr(" ")), sticky="w")
tkgrid(spaceFrame3, sticky="w", row=6, column=2, columnspan=1)
spaceFrame4 <- tkframe(top)
tkgrid(labelRcmdr(spaceFrame4, text=gettextRcmdr(" ")), sticky="w")
tkgrid(spaceFrame4, sticky="w", row=7, column=1, columnspan=1)
tkgrid(buttonsFrame, sticky="w", row=9, column=1, columnspan=2)
dialogSuffix(rows=9, columns=1)
}
#####################################
# Goodness of fit tests
deviance_tests_GUI <- function(){
doItAndPrint("deviance_tests()")
}
#####################################
# (X'X)^-1 = solve(crossprod(X))
invXtXGUI <- function(){
initializeDialog(title=gettextRcmdr("Store and/or display (X'X)^-1 (inverse regressor covariance)"))
mainFrame <- tkframe(top)
onOK <- function(){ # Actions to perform
command <- paste("solve(crossprod(model.matrix(",ActiveModel(),")))",sep="")
stored <- tclvalue(storeVariable)
if(stored == gettextRcmdr("1")){
doItAndPrint(paste("invXtX <- ", command, sep=""))
}
displayed <- tclvalue(displayVariable)
if(displayed == gettextRcmdr("1")){
doItAndPrint(command)
}
closeDialog()
tkfocus(CommanderWindow())
}
# Set up GUI
OKCancelHelp(helpSubject="lm")
checkBoxes(frame="mainFrame", boxes=c("store","display"), initialValues=c("1","1"),
labels=gettextRcmdr(c("Store matrix as invXtX","Display matrix")))
tkgrid(mainFrame, row=1, column=1, columnspan=1, rowspan=1, sticky="w")
tkgrid(buttonsFrame, sticky="w", row=2, column=1, columnspan=1)
dialogSuffix(rows=2, columns=1)
}
Try the RcmdrPlugin.UMB package in your browser
Any scripts or data that you put into this service are public.
RcmdrPlugin.UMB documentation built on May 2, 2019, 5:27 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions predictRegressionModel forwardAdd backwardDrop forwardBackward backwardForward bestSubsets discriminantPlot contrastGUI contrastGUI2 postHocGUI mixtureGUI anova_reg_GUI PRESS.GUI addObservationStatisticsUMB deviance_tests_GUI invXtXGUI
Documented in addObservationStatisticsUMB anova_reg_GUI backwardDrop backwardForward bestSubsets contrastGUI contrastGUI2 deviance_tests_GUI discriminantPlot forwardAdd forwardBackward invXtXGUI mixtureGUI postHocGUI predictRegressionModel PRESS.GUI
# $Id: UMB.GUI.Models.R 28 2013-11-07 21:31:50Z khliland $
##
## GUI functions for the Model menu
##
## GUI tips
#
# Usual code structure:
# 1. Intitialise window and prepare graphical elements
# 2. onOK function contianing actions to perform
# 2.1 Collect values from GUI
# 2.2 Test if combination of values is usable
# 2.3 Perform main calculations, print, update models/data etc.
# 3. Set up GUI.
# - tkgrid() adds elements. Explicit placement and width/heigth by colum, row, columnspan and rowspan
# - Frames with graphical elements are safer than direct placement of elements due to version conflicts.
# - dialogSuffix() defines the final size of the grid used for elements.
#########################################################
# Prediction for LDA/QDA, PCR/PLSR and linear regression
predictRegressionModel <- function(){
# Boks som tar imot verdiene til alle preditorene, kommaseparert (navnerekkef?lge m? framkomme, f.eks. med formula).
# Konfidensgrad for CI og PI.
.activeModel <- ActiveModel()
model.class <- justDoIt(paste("class(", .activeModel, ")", sep=""))[1]
if(model.class == "mvr"){
initializeDialog(title=gettextRcmdr("Prediction in multivariate regression"))
ff <- justDoIt(paste("fparse(formula(", .activeModel, "))", sep=""))
ncomp <- justDoIt(paste(.activeModel, "$ncomp", sep=""))
} else {
if(model.class == "lda" || model.class == "qda"){
initializeDialog(title=gettextRcmdr("Prediction in discriminant analysis"))
ff <- justDoIt(paste("colnames(", .activeModel, "$means)", sep=""))
} else {
if(model.class == "lm"){
initializeDialog(title=gettextRcmdr("Prediction in linear regression"))
ff <- justDoIt(paste("fparse(formula(", .activeModel, "))", sep=""))
} else {
initializeDialog(title=gettextRcmdr("Prediction in generalized linear model"))
ff <- justDoIt(paste("fparse(formula(", .activeModel, "))", sep=""))
}
}}
n.eff <- length(ff)
effNames <- list()
effFrames <- list()
effs <- list()
for(i in 1:n.eff){
effNames[[i]] <- tclVar('0')
effFrames[[i]] <- tkframe(top)
effs[[i]] <- ttkentry(effFrames[[i]], width="7", textvariable=effNames[[i]])
}
if(model.class == "lm"){
levelName <- tclVar("0.95")
levelFrame <- tkframe(top)
level <- ttkentry(levelFrame, width="5", textvariable=levelName)
extrapFrame <- tkframe(top)
}
if(model.class == "mvr"){
compName <- tclVar(ncomp)
compFrame <- tkframe(top)
comp <- ttkentry(compFrame, width="5", textvariable=compName)
typeFrame <- tkframe(top)
}
onOK <- function(){ # Actions to perform
closeDialog()
the.effs <- list()
for(i in 1:n.eff){
the.effs[[i]] <- tclvalue(effNames[[i]])
}
if(model.class == "lm"){
levs <- tclvalue(levelName)
if(trim.blanks(levs) == gettextRcmdr("")){
errorCondition(recall=predictRegressionModel, message=gettextRcmdr("Please specify confidence level."))
}
}
if(model.class == "mvr"){
the.comps <- tclvalue(compName)
if(trim.blanks(the.comps) == gettextRcmdr("")){
errorCondition(recall=predictRegressionModel, message=gettextRcmdr("Please specify the number of components to use."))
}
the.type <- as.character(tclvalue(typeVariable))
}
doItAndPrint(paste("attach(", ActiveDataSet(), ")", sep=""))
command <- paste("predict(", .activeModel, ", data.frame(", sep="")
for(i in 1:n.eff){
command <- paste(command, "'", ff[[i]], "'", "=", the.effs[[i]], sep="")
if(i<n.eff)
command <- paste(command, ", ", sep="")
}
if(model.class == "mvr"){
command <- paste(command, "), ncomp=", the.comps, ", type='", the.type, "')", sep="")
} else {
if(model.class == "lm"){
command <- gsub("predict(", "predict_CI_PI(", command, fixed=TRUE)
extrap <- tclvalue(extrapVariable)
if(extrap == gettextRcmdr("1")){
command <- paste(command, "), level=", levs, ", xXXx=TRUE)", sep="")
} else {
command <- paste(command, "), level=", levs, ")", sep="")
}
} else {
if(model.class == "glm"){
command <- gsub("predict(", "predict_link_response(", command, fixed=TRUE)
command <- paste(command, "))", sep="")
} else {
command <- paste(command, "))[1:2]", sep="")
}
}
}
doItAndPrint(command)
if(model.class == "lm" && extrap == gettextRcmdr("1")){
doItAndPrint(paste("max(hatvalues(", .activeModel, ")) # h_max", sep=""))}
# if(model.class == "lm"){
# extrap <- tclvalue(extrapVariable)
# if(extrap == gettextRcmdr("1")){
# command <- paste("X.tmp <- model.matrix(",.activeModel, "); x.tmp <- data.frame(", sep="")
# for(i in 1:n.eff){
# command <- paste(command, "'", ff[[i]], "'", "=", the.effs[[i]], sep="")
# if(i<n.eff)
# command <- paste(command, ", ", sep="")
# }
# justDoIt(paste(command, ")", sep=""))
# justDoIt(paste("x.tmp <- cbind('(Intercept)'=1, as.matrix(x.tmp))", sep=""))
# doItAndPrint(paste("xXXx(X.tmp,x.tmp) # h_00", sep=""))
# doItAndPrint(paste("max(hatvalues(", .activeModel, ")) # h_max", sep=""))
# justDoIt("rm(c('X.tmp','x.tmp'))")
# }
# }
doItAndPrint(paste("detach(", ActiveDataSet(), ")", sep=""))
tkfocus(CommanderWindow())
}
# Set up GUI
OKCancelHelp(helpSubject="predict", model=TRUE)
tkgrid(labelRcmdr(top,text='Specify value of explanatory variable(s)', fg="blue"),sticky="w", row=1, column=1, columnspan=max(n.eff,2))
for(i in 1:n.eff){
tkgrid(labelRcmdr(effFrames[[i]],text=gettextRcmdr(ff[i])),sticky="w")
tkgrid(effs[[i]], sticky="w")
tkgrid(effFrames[[i]], row=2, column=i)
}
tkgrid(labelRcmdr(top,text=''),sticky="w", row=3, column=1, columnspan=max(n.eff,2))
n.row <- 4
if(model.class == "lm"){
tkgrid(labelRcmdr(levelFrame, text=gettextRcmdr("Confidence level:")), level, sticky="w")
tkgrid(levelFrame, sticky="n", row=4, column=1, columnspan=max(floor(n.eff/2),1))
checkBoxes(frame="extrapFrame", boxes=c("extrap"), initialValues=c("0"),
labels=gettextRcmdr(c("Detect hidden extrapolation")))
tkgrid(extrapFrame, sticky="n", row=4, column=max(2, ceiling(n.eff/2)), columnspan=n.eff-floor(n.eff/2))
n.row <- 5
}
if(model.class == "mvr"){
tkgrid(labelRcmdr(compFrame, text=gettextRcmdr("Number of components:")), comp, sticky="w")
tkgrid(compFrame, sticky="n", row=4, column=1, columnspan=max(n.eff,2))
radioButtons(name="type", buttons=c("response", "scores"), values=c("response", "scores"), initialValue="response",
labels=gettextRcmdr(c("Response", "Scores")), title=gettextRcmdr("Type of prediction"))
tkgrid(typeFrame, sticky="n", row=5, column=1, columnspan=max(n.eff,2))
n.row <- 6
}
tkgrid(buttonsFrame, stick="s", row=n.row, column=1, columnspan=max(n.eff,2))
tkgrid.configure(helpButton, sticky="se")
dialogSuffix(rows=n.row, columns=max(n.eff,2))
}
###################################
## Stepwise and subset methods
forwardAdd <- function(){
.activeModel <- ActiveModel()
availableTerms <- justDoIt(paste("attr(",.activeModel,"$terms,'term.labels')",sep=""))
initializeDialog(title=gettextRcmdr("Stepwise forward selection"))
# Boks for signifikans ved ny variabel
alphaName <- tclVar("0.2")
alphaFrame <- tkframe(top)
fullFrame <- tkframe(top)
alpha <- ttkentry(alphaFrame, width="10", textvariable=alphaName)
xBox <- variableListBox(top, availableTerms, selectmode="multiple", title=gettextRcmdr("Compulsory variables (pick zero or more)"))
onOK <- function(){ # Actions to perform
x <- getSelection(xBox)
closeDialog()
the.alpha <- tclvalue(alphaName)
if(trim.blanks(the.alpha) == gettextRcmdr("")){
warning('Please specify the alpha level for entering')
}
fullmodel <- tclvalue(fullmodelVariable)
force.in <- 'NULL'
if(length(x)>0){
force.in <- paste("'",paste(x, collapse="+"),"'", sep="")}
command <- paste("forward(", .activeModel, ", alpha=", the.alpha, ", full=",ifelse(fullmodel == gettextRcmdr("1"), 'TRUE', 'FALSE'),", force.in=",force.in,")", sep="")
doItAndPrint(command)
tkfocus(CommanderWindow())
}
# Set up GUI
OKCancelHelp(helpSubject="add", model=TRUE)
tkgrid(labelRcmdr(alphaFrame, text=gettextRcmdr("Alpha to enter:")), alpha, sticky="w")
tkgrid(alphaFrame, sticky="n")
checkBoxes(frame="fullFrame", boxes=c("fullmodel"), initialValues=c("0"),
labels=gettextRcmdr(c("Extended output")))
tkgrid(fullFrame, sticky="n")
tkgrid(getFrame(xBox), sticky = "n")
tkgrid(buttonsFrame, stick="s")
tkgrid.configure(helpButton, sticky="se")
dialogSuffix(rows=3, columns=2)
}
backwardDrop <- function(){
.activeModel <- ActiveModel()
availableTerms <- justDoIt(paste("attr(",.activeModel,"$terms,'term.labels')",sep=""))
initializeDialog(title=gettextRcmdr("Stepwise backward eliminiation"))
# Boks for signifikans ved ny variabel
alphaName <- tclVar("0.2")
alphaFrame <- tkframe(top)
fullFrame <- tkframe(top)
alpha <- ttkentry(alphaFrame, width="10", textvariable=alphaName)
xBox <- variableListBox(top, availableTerms, selectmode="multiple", title=gettextRcmdr("Compulsory variables (pick zero or more)"))
onOK <- function(){ # Actions to perform
x <- getSelection(xBox)
closeDialog()
the.alpha <- tclvalue(alphaName)
if(trim.blanks(the.alpha) == gettextRcmdr("")){
warning('Please specify the alpha level for elimination')
}
fullmodel <- tclvalue(fullmodelVariable)
force.in <- 'NULL'
if(length(x)>0){
force.in <- paste("c('",paste(x, collapse="','"),"')", sep="")}
command <- paste("backward(", .activeModel, ", alpha=", the.alpha, ", full=",ifelse(fullmodel == gettextRcmdr("1"), 'TRUE', 'FALSE'),", force.in=",force.in,")", sep="")
doItAndPrint(command)
tkfocus(CommanderWindow())
}
# Set up GUI
OKCancelHelp(helpSubject="drop", model=TRUE)
tkgrid(labelRcmdr(alphaFrame, text=gettextRcmdr("Alpha to remove:")), alpha, sticky="w")
tkgrid(alphaFrame, sticky="n")
checkBoxes(frame="fullFrame", boxes=c("fullmodel"), initialValues=c("0"),
labels=gettextRcmdr(c("Extended output")))
tkgrid(fullFrame, sticky="n")
tkgrid(getFrame(xBox), sticky = "n")
tkgrid(buttonsFrame, stick="s")
tkgrid.configure(helpButton, sticky="se")
dialogSuffix(rows=3, columns=2)
}
forwardBackward <- function(){
.activeModel <- ActiveModel()
initializeDialog(title=gettextRcmdr("Stepwise forward/backward selection"))
# Boks for signifikans ved ny variabel
alphaName <- tclVar("0.15")
alphaFrame <- tkframe(top)
alpha1Name <- tclVar("0.15")
alpha1Frame <- tkframe(top)
fullFrame <- tkframe(top)
alpha <- ttkentry(alphaFrame, width="10", textvariable=alphaName)
alpha1 <- ttkentry(alpha1Frame, width="10", textvariable=alpha1Name)
onOK <- function(){ # Actions to perform
closeDialog()
the.alpha <- tclvalue(alphaName)
if(trim.blanks(the.alpha) == gettextRcmdr("")){
warning('Please specify the alpha level for entering')
}
the.alpha1 <- tclvalue(alpha1Name)
if(trim.blanks(the.alpha1) == gettextRcmdr("")){
warning('Please specify the alpha level for removing')
}
fullmodel <- tclvalue(fullmodelVariable)
if(fullmodel == gettextRcmdr("1")){
command <- paste("stepWise(", .activeModel, ", alpha.enter=", the.alpha, ", alpha.remove=", the.alpha1, ", full=TRUE)", sep="")
doItAndPrint(command)
} else{
command <- paste("stepWise(", .activeModel, ", alpha.enter=", the.alpha, ", alpha.remove=", the.alpha1, ", full=FALSE)", sep="")
doItAndPrint(command)}
tkfocus(CommanderWindow())
}
# Set up GUI
OKCancelHelp(helpSubject="add", model=TRUE)
tkgrid(labelRcmdr(alphaFrame, text=gettextRcmdr("Alpha to enter:")), alpha, sticky="w")
tkgrid(alphaFrame, sticky="n")
tkgrid(labelRcmdr(alpha1Frame, text=gettextRcmdr("Alpha to remove:")), alpha1, sticky="w")
tkgrid(alpha1Frame, sticky="n")
checkBoxes(frame="fullFrame", boxes=c("fullmodel"), initialValues=c("0"),
labels=gettextRcmdr(c("Extended output")))
tkgrid(fullFrame, sticky="n")
tkgrid(buttonsFrame, stick="s")
tkgrid.configure(helpButton, sticky="se")
dialogSuffix(rows=4, columns=2)
}
backwardForward <- function(){
.activeModel <- ActiveModel()
initializeDialog(title=gettextRcmdr("Stepwise backward/forward selection"))
# Boks for signifikans ved ny variabel
alphaName <- tclVar("0.15")
alphaFrame <- tkframe(top)
alpha1Name <- tclVar("0.15")
alpha1Frame <- tkframe(top)
fullFrame <- tkframe(top)
alpha <- ttkentry(alphaFrame, width="10", textvariable=alphaName)
alpha1 <- ttkentry(alpha1Frame, width="10", textvariable=alpha1Name)
onOK <- function(){ # Actions to perform
closeDialog()
the.alpha <- tclvalue(alphaName)
if(trim.blanks(the.alpha) == gettextRcmdr("")){
warning('Please specify the alpha level for removing')
}
the.alpha1 <- tclvalue(alpha1Name)
if(trim.blanks(the.alpha1) == gettextRcmdr("")){
warning('Please specify the alpha level for entering')
}
fullmodel <- tclvalue(fullmodelVariable)
if(fullmodel == gettextRcmdr("1")){
command <- paste("stepWiseBack(", .activeModel, ", alpha.remove=", the.alpha, ", alpha.enter=", the.alpha1, ", full=TRUE)", sep="")
doItAndPrint(command)}
else{
command <- paste("stepWiseBack(", .activeModel, ", alpha.remove=", the.alpha, ", alpha.enter=", the.alpha1, ", full=FALSE)", sep="")
doItAndPrint(command)}
tkfocus(CommanderWindow())
}
# Set up GUI
OKCancelHelp(helpSubject="drop", model=TRUE)
tkgrid(labelRcmdr(alphaFrame, text=gettextRcmdr("Alpha to remove:")), alpha, sticky="w")
tkgrid(alphaFrame, sticky="n")
tkgrid(labelRcmdr(alpha1Frame, text=gettextRcmdr("Alpha to enter:")), alpha1, sticky="w")
tkgrid(alpha1Frame, sticky="n")
checkBoxes(frame="fullFrame", boxes=c("fullmodel"), initialValues=c("0"),
labels=gettextRcmdr(c("Extended output")))
tkgrid(fullFrame, sticky="n")
tkgrid(buttonsFrame, stick="s")
tkgrid.configure(helpButton, sticky="se")
dialogSuffix(rows=4, columns=2)
}
bestSubsets <- function(){
.activeModel <- ActiveModel()
availableTerms <- justDoIt(paste("attr(",.activeModel,"$terms,'term.labels')",sep=""))
initializeDialog(title=gettextRcmdr("Best subset regression"))
# Bokser for antall
nbestName <- tclVar("3")
nbestFrame <- tkframe(top)
nvmaxName <- tclVar("3")
nvmaxFrame <- tkframe(top)
nbest <- ttkentry(nbestFrame, width="10", textvariable=nbestName)
nvmax <- ttkentry(nvmaxFrame, width="10", textvariable=nvmaxName)
# Valg av faste variabler
xBox <- variableListBox(top, availableTerms, selectmode="multiple", title=gettextRcmdr("Compulsory variables (pick zero or more)"))
onOK <- function(){ # Actions to perform
x <- getSelection(xBox)
closeDialog()
the.nbest <- tclvalue(nbestName)
if(trim.blanks(the.nbest) == gettextRcmdr("")){
warning('Please specify the number of models per model size')
}
the.nvmax <- tclvalue(nvmaxName)
if(trim.blanks(the.nvmax) == gettextRcmdr("")){
warning('Please specify the maximum model size')
}
force.in <- 'NULL'
if(length(x)>0){
force.in <- paste("'c(",paste(is.element(availableTerms,x), collapse=","),")'", sep="")}
command <- paste("best.subsets(", .activeModel, ", nbest=", the.nbest, ", nvmax=", the.nvmax, ", force.in=", force.in,")", sep="")
doItAndPrint(command)
tkfocus(CommanderWindow())
}
# Set up GUI
OKCancelHelp(helpSubject="regsubsets", model=TRUE)
tkgrid(labelRcmdr(nbestFrame, text=gettextRcmdr("Number of models per model size:")), nbest, sticky="w")
tkgrid(nbestFrame, sticky="n")
tkgrid(labelRcmdr(nvmaxFrame, text=gettextRcmdr("Maximum model size:")), nvmax, sticky="w")
tkgrid(nvmaxFrame, sticky="n")
tkgrid(getFrame(xBox), sticky = "n")
tkgrid(buttonsFrame, stick="s")
tkgrid.configure(helpButton, sticky="se")
dialogSuffix(rows=4, columns=2)
}
################################
## 2D discrinimant plot
discriminantPlot <- function(){
initializeDialog(title=gettextRcmdr("Two-dimensional discriminant plot"))
boxFrame <- tkframe(top)
sliderFrame <- tkframe(top)
sliderValue <- tclVar("100")
componentsSlider <- tkscale(sliderFrame, from=50, to=500, showvalue=FALSE, variable=sliderValue,
resolution=50, orient="horizontal")
componentsShow <- labelRcmdr(sliderFrame, textvariable=sliderValue, width=3, justify="right")
onOK <- function(){ # Actions to perform
the.slider <- as.numeric(tclvalue(sliderValue))
closeDialog()
the.regions <- tclvalue(regionsVariable)
the.contours <- tclvalue(contoursVariable)
if(the.regions == gettextRcmdr("1") && the.contours == gettextRcmdr("1")){
command <- paste("plotDA(regions=TRUE, contours=TRUE, resolution=", the.slider, ")", sep="")
}
if(the.regions == gettextRcmdr("0") && the.contours == gettextRcmdr("1")){
command <- paste("plotDA(regions=FALSE, contours=TRUE, resolution=", the.slider, ")", sep="")
}
if(the.regions == gettextRcmdr("1") && the.contours == gettextRcmdr("0")){
command <- paste("plotDA(regions=TRUE, contours=FALSE, resolution=", the.slider, ")", sep="")
}
if(the.regions == gettextRcmdr("0") && the.contours == gettextRcmdr("0")){
command <- paste("plotDA(regions=FALSE, contours=FALSE, resolution=", the.slider, ")", sep="")
}
logger(command)
justDoIt(command)
tkfocus(CommanderWindow())
}
# Set up GUI
OKCancelHelp(helpSubject="plot", model=TRUE)
tkgrid(labelRcmdr(top, text=gettextRcmdr("Plot resolution:"), fg="blue"), sticky="w")
tkgrid(componentsSlider, componentsShow, sticky="nw")
tkgrid(sliderFrame, sticky="w")
checkBoxes(frame="boxFrame", boxes=c("regions","contours"), initialValues=c("1","0"),
labels=gettextRcmdr(c("Show discriminant regions", "Show binormal contours")))
tkgrid(boxFrame, sticky="w")
tkgrid(buttonsFrame, stick="s")
tkgrid.configure(helpButton, sticky="se")
dialogSuffix(rows=5, columns=2)
}
#####################################
# ANOVA contrasts
contrastGUI <- function(){
.activeModel <- ActiveModel()
levs <- justDoIt(paste(.activeModel, "$xlevels", sep=""))
if(length(levs)==0 || length(levs)>2){
return()
}
if(length(levs)>1){
initializeDialog(title=gettextRcmdr("Test contrasts in ANOVA (choose factor)"))
xFrame <- tkframe(top)
xBox <- variableListBox(xFrame, names(levs),
title=gettextRcmdr("Factors (pick one)"))
onOK <- function(){ # Actions to perform
x <- getSelection(xBox)
closeDialog()
if (length(x)==0) {
errorCondition(recall=contrastGUI,
message=gettextRcmdr("No variables selected."))
return()
}
contrastGUI2(which(names(levs)==x),levs)
}
OKCancelHelp(helpSubject="fit.contrast", model=TRUE)
tkgrid(getFrame(xBox), sticky="nw")
tkgrid(xFrame, sticky="w")
tkgrid(buttonsFrame, sticky="w")
tkgrid.configure(helpButton, sticky="se")
dialogSuffix(rows=2, columns=1)
} else{
contrastGUI2(1,levs)
}
}
contrastGUI2 <- function(varNumb,levs){
# Boks som tar imot verdiene til alle prediktorene, kommaseparert (navnerekkef?lge m? framkomme, f.eks. med formula).
# Konfidensgrad for CI og PI.
initializeDialog(title=gettextRcmdr("Test contrasts in ANOVA"))
.activeModel <- ActiveModel()
ff <- justDoIt(paste(.activeModel, "$xlevels[[", varNumb, "]]", sep=""))
fn <- justDoIt(paste("names(", .activeModel, "$xlevels)[[", varNumb, "]]", sep=""))
n.eff <- length(ff)
effNames <- list()
effFrames <- list()
effs <- list()
if(n.eff>2){
for(i in 1:n.eff){
effNames[[i]] <- tclVar('0')
effFrames[[i]] <- tkframe(top)
effs[[i]] <- ttkentry(effFrames[[i]], width=5, textvariable=effNames[[i]])
}
} else{
effNames[[1]] <- tclVar('1')
effNames[[2]] <- tclVar('-1')
effFrames[[1]] <- tkframe(top)
effFrames[[2]] <- tkframe(top)
effs[[1]] <- ttkentry(effFrames[[1]], width=5, textvariable=effNames[[1]])
effs[[2]] <- ttkentry(effFrames[[2]], width=5, textvariable=effNames[[2]])
}
levelName <- tclVar("0.95")
levelFrame <- tkframe(top)
level <- ttkentry(levelFrame, width="10", textvariable=levelName)
onOK <- function(){ # Actions to perform
closeDialog()
effValues <- numeric(n.eff)
for(i in 1:n.eff){
effValues[i] <- try(eval(parse(text=(tclvalue(effNames[[i]])))))
}
if(abs(sum(effValues)) >= 0.1){
errorCondition(recall=contrastGUI2, message=gettextRcmdr("Contrasts must sum to 0 (total deviance allowed=0.1)."))
return()
}
levelValue <- as.numeric(tclvalue(levelName))
if(levelValue <= 0 || levelValue >= 1){
errorCondition(recall=contrastGUI2, message=gettextRcmdr("Confidence level must be >0 and <1."))
return()
}
# level.name <- justDoIt(paste("names(",.activeModel, "$xlevels)", sep=""))
command <- paste("print(fit.contrast(model=", ActiveModel(), ", varname='",fn, "', df=TRUE, coeff=c(", effValues[1], sep="")
for(i in 2:n.eff){
command <- paste(command, ", ", effValues[i], sep="")
}
command <- paste(command, "), conf.int=", levelValue,"))", sep="")
# If interaction, test per level, not across levels
has.interaction <- justDoIt(paste("max(apply(attr(",.activeModel, "$terms,'factors'),1,sum))>1", sep=""))
if(length(levs)>1 && has.interaction){
the.levels <- justDoIt(paste("levels(",ActiveDataSet(),"$",names(levs[3-varNumb]),")",sep=""))
for(i in 1:length(the.levels)){
doItAndPrint(paste(paste("cat('Contrast for ",names(levs[3-varNumb]), " = ", the.levels[1], "\n')", sep=""),command, sep="; "))
# doItAndPrint(command)
the.levels <- c(the.levels[-1],the.levels[1])
doItAndPrint(paste(ActiveDataSet(),"$",names(levs[3-varNumb]), " <- factor(", ActiveDataSet(),"$",names(levs[3-varNumb]), ", levels=c('",paste(the.levels,sep="",collapse="','"),"'))",sep=""))
}
} else {
doItAndPrint(command)
}
#logger(command)
tkfocus(CommanderWindow())
}
# Set up GUI
OKCancelHelp(helpSubject="fit.contrast", model=TRUE)
tkgrid(labelRcmdr(top,text=paste('Specify contrast for ', fn, sep=""), fg="blue"),sticky="w", row=1, column=1, columnspan=n.eff)
for(i in 1:n.eff){
tkgrid(labelRcmdr(effFrames[[i]],text=gettextRcmdr(ff[i])),sticky="w")
tkgrid(effs[[i]], sticky="w")
tkgrid(effFrames[[i]], row=2, column=i)
}
tkgrid(labelRcmdr(top,text=''),sticky="w", row=3, column=1, columnspan=n.eff)
tkgrid(labelRcmdr(levelFrame, text=gettextRcmdr("Confidence level:")), level, sticky="w")
tkgrid(levelFrame, sticky="w", row=4, column=1, columnspan=n.eff)
tkgrid(buttonsFrame, stick="s", row=5, column=1, columnspan=n.eff)
tkgrid.configure(helpButton, sticky="se")
dialogSuffix(rows=5, columns=n.eff)
}
#####################################
# Post hoc tests
postHocGUI <- function(){
initializeDialog(title=gettextRcmdr("Post hoc pair-wise tests"))
.activeModel <- ActiveModel()
effects <- eval(parse(text=paste("attr(terms(formula(",.activeModel,")),'term.labels')", sep="")))
# if(glmP()){
# effects <- effects[!grepl(":",effects)]
# }
xFrame <- tkframe(top)
# if(glmP()){
xBox <- variableListBox(xFrame, effects,
title=gettextRcmdr("Effects (pick one)"))
# } else {
# xBox <- variableListBox(xFrame, effects, selectmode="multiple",
# title=gettextRcmdr("Effects (pick one or more)"))
#}
comboFrame <- tkframe(top)
levs <- justDoIt(paste(.activeModel, "$xlevels", sep=""))
levNames <- names(levs)
values <- NULL
valuesLookUp <- NULL
comboVar <- tclVar()
for(i in 1:length(levNames)){
values <- c(values, paste(levNames[i], levs[[i]], sep=", "))
valuesLookUp <- rbind(valuesLookUp, cbind(rep(levNames[i],length(levs[[i]])),levs[[i]]))
}
onOK <- function(){
x <- getSelection(xBox)
selectedDunnett <- which(values==tclvalue(comboVar))
if(length(x)==0 && length(selectedDunnett)==0){
errorCondition(recall=postHocGUI, message=gettextRcmdr("Pick at least one effect for pair-wise comparisons other than Dunnett."))
return()
}
if(length(x)==1){
selected <- paste("'",x,"'",sep="")
} else {
selected <- paste("c('",paste(x,sep="",collapse="','"),"')", sep="")
}
the.tukey <- tclvalue(tukeyName)
if(tclvalue(tukeyTestsVariable)== gettextRcmdr("1")){
command <- paste("print(simple.glht(", ActiveModel(), ",",selected,", level=", the.tukey,"))",sep="")
# if(glmP()){
# command <- paste("summary(glht(", ActiveModel(), ", linfct=mcp(", x, "='Tukey')))", sep="")
# } else {
# command <- paste("TukeyHSD(", ActiveModel(), ",",selected,", conf.level=",the.tukey,")",sep="")
# }
doItAndPrint(command)
}
if(tclvalue(tukeyGroupsVariable)== gettextRcmdr("1")){
command <- paste("cld(simple.glht(", ActiveModel(), ",",selected,", level=", the.tukey,"))",sep="")
# if(glmP()){
# command <- paste("multcomp:::print.cld(multcomp::cld(glht(", ActiveModel(), ", linfct=mcp(", x, "='Tukey'))))", sep="")
# } else {
# command <- paste("cld(TukeyHSD(", ActiveModel(), ", ", selected, "), ", 1-as.numeric(the.tukey),")", sep="")
# }
doItAndPrint(command)
}
# if(!glmP()){
the.bonferroni <- tclvalue(bonferroniName)
if(tclvalue(bonferroniTestsVariable)== gettextRcmdr("1")){
command <- paste("print(simple.glht(", ActiveModel(), ",",selected,", corr='Bonferroni', level=", the.tukey,"))",sep="")
# command <- paste("Bonferroni(", ActiveModel(), ",",selected,", conf.level=",the.bonferroni,")",sep="")
doItAndPrint(command)
}
if(tclvalue(bonferroniGroupsVariable)== gettextRcmdr("1")){
command <- paste("cld(simple.glht(", ActiveModel(), ",",selected,", corr='Bonferroni', level=", the.tukey,"))",sep="")
doItAndPrint(command)
# doItAndPrint(paste("cld(Bonferroni(", ActiveModel(), ", ", selected, "), ", 1-as.numeric(the.bonferroni), ")", sep=""))
}
the.fisher <- tclvalue(fisherName)
if(tclvalue(fisherTestsVariable)== gettextRcmdr("1")){
command <- paste("print(simple.glht(", ActiveModel(), ",",selected,", corr='Fisher', level=", the.tukey,"))",sep="")
# command <- paste("Fisher(", ActiveModel(), ",",selected,", conf.level=",the.fisher,")",sep="")
doItAndPrint(command)
}
if(tclvalue(fisherGroupsVariable)== gettextRcmdr("1")){
command <- paste("cld(simple.glht(", ActiveModel(), ",",selected,", corr='Fisher', level=", the.tukey,"))",sep="")
doItAndPrint(command)
# doItAndPrint(paste("cld(Fisher(", ActiveModel(), ", ", selected, "), ", 1-as.numeric(the.fisher), ")", sep=""))
}
if(length(selectedDunnett)>0){
effect <- valuesLookUp[selectedDunnett,1]
level <- valuesLookUp[selectedDunnett,2]
command <- paste("levels(", ActiveModel(), "$model[,'", effect, "'])", sep="")
effLevs.orig <- effLevs <- justDoIt(command)
if(effLevs[1]!=level){
effLevs <- c(level, effLevs[!is.element(effLevs,level)])
command <- paste(ActiveDataSet(), "$", effect, " <- factor(", ActiveDataSet(), "$", effect, ", levels=c('", paste(effLevs,sep="", collapse="', '"), "'))", sep="")
doItAndPrint(command)
doItAndPrint(paste(ActiveModel(), " <- update(",ActiveModel(),")",sep=""))
}
command <- paste("summary(glht(", ActiveModel(), ", linfct = mcp(", effect, " = 'Dunnett')))", sep="")
doItAndPrint(command)
if(effLevs.orig[1]!=level){
command <- paste(ActiveDataSet(), "$", effect, " <- factor(", ActiveDataSet(), "$", effect, ", levels=c('", paste(effLevs.orig,sep="", collapse="', '"), "'))", sep="")
doItAndPrint(command)
doItAndPrint(paste(ActiveModel(), " <- update(",ActiveModel(),")",sep=""))
}
}
# }
closeDialog()
return()
}
OKCancelHelp(helpSubject="simple.glht")
tkgrid(getFrame(xBox), sticky="nw")
tkgrid(xFrame, row=1, column=1, columnspan=2, sticky="w")
topFrame <- tkframe(top)
tkgrid(labelRcmdr(topFrame, text=gettextRcmdr("Tukey HSD"), fg="blue"),sticky="w")
tkgrid(topFrame, row=2, column=1, columnspan=1, sticky="w")
checkBoxes(frame="tukeyFrame", boxes=c("tukeyTests","tukeyGroups"), initialValues=c("0","0"),
labels=gettextRcmdr(c("Tests","Groups")))
tkgrid(tukeyFrame, row=3, column=1, columnspan=1, rowspan=1, sticky="w")
tukeyName <- tclVar("0.95")
tukeyFrameGr <- tkframe(top)
tukey <- ttkentry(tukeyFrameGr, width="6", textvariable=tukeyName)
tkgrid(labelRcmdr(tukeyFrameGr, text=gettextRcmdr("Confidence")), tukey, sticky="w")
tkgrid(tukeyFrameGr, sticky="w", row=3, column=2)
# if(!glmP()){
topFrame2 <- tkframe(top)
tkgrid(labelRcmdr(topFrame2, text=gettextRcmdr("Bonferroni"), fg="blue"),sticky="w")
tkgrid(topFrame2, row=4, column=1, columnspan=1, sticky="w")
checkBoxes(frame="bonferroniFrame", boxes=c("bonferroniTests","bonferroniGroups"), initialValues=c("0","0"),
labels=gettextRcmdr(c("Tests","Groups")))
tkgrid(bonferroniFrame, row=5, column=1, columnspan=1, rowspan=1, sticky="w")
bonferroniName <- tclVar("0.95")
bonferroniFrameGr <- tkframe(top)
bonferroni <- ttkentry(bonferroniFrameGr, width="6", textvariable=bonferroniName)
tkgrid(labelRcmdr(bonferroniFrameGr, text=gettextRcmdr("Confidence")), bonferroni, sticky="w")
tkgrid(bonferroniFrameGr, sticky="w", row=5, column=2)
topFrame3 <- tkframe(top)
tkgrid(labelRcmdr(topFrame3, text=gettextRcmdr("Fisher"), fg="blue"),sticky="w")
tkgrid(topFrame3, row=6, column=1, columnspan=1, sticky="w")
checkBoxes(frame="fisherFrame", boxes=c("fisherTests","fisherGroups"), initialValues=c("0","0"),
labels=gettextRcmdr(c("Tests","Groups")))
tkgrid(fisherFrame, row=7, column=1, columnspan=1, rowspan=1, sticky="w")
fisherName <- tclVar("0.95")
fisherFrameGr <- tkframe(top)
fisher <- ttkentry(fisherFrameGr, width="6", textvariable=fisherName)
tkgrid(labelRcmdr(fisherFrameGr, text=gettextRcmdr("Confidence")), fisher, sticky="w")
tkgrid(fisherFrameGr, sticky="w", row=7, column=2)
topFrame1 <- tkframe(top)
tkgrid(labelRcmdr(topFrame1, text=gettextRcmdr("Dunnet"), fg="blue"),sticky="w")
tkgrid(topFrame1, row=8, column=1, columnspan=1, sticky="w")
combo <- ttkcombobox(comboFrame, values=values, textvariable=comboVar)
tkgrid(labelRcmdr(comboFrame, text=gettextRcmdr("Choose comparison:")), combo, sticky="w")
tkgrid(comboFrame, sticky="w", column=1, row=9, columnspan=2)
# }
tkgrid(buttonsFrame, sticky="w", column=1, row=10, columnspan=2)
dialogSuffix(rows=10, columns=2)
}
#####################################
# Plot mixture experiment
mixtureGUI <- function(){
initializeDialog(title=gettextRcmdr("Plot response surface for mixture design"))
.numeric <- Numeric()
comboVar <- tclVar()
comboFrame <- tkframe(top)
comboVar2 <- tclVar()
comboFrame2 <- tkframe(top)
formatFrame <- tkframe(top)
zoomFrame <- tkframe(top)
onOK <- function(){ # Actions to perform
mix.format <- as.character(tclvalue(label.formatVariable))
zoomed <- tclvalue(zoomedVariable)
if(zoomed == gettextRcmdr("1")){
zoomed <- "TRUE"
} else {
zoomed <- "FALSE"
}
show.points <- tclvalue(samplesVariable)
if(show.points == gettextRcmdr("1")){
show.points <- "TRUE"
} else {
show.points <- "FALSE"
}
logen <- ifelse(tclvalue(logVariable)== gettextRcmdr("1"), TRUE, FALSE)
n.ticks <- which(as.character(2:10)==tclvalue(comboVar))+1
if(length(n.ticks)==0) n.ticks <- "6"
n.grade <- which(as.character(seq(5,25,5))==tclvalue(comboVar2))*5
if(length(n.grade)==0) n.grade <- "15"
closeDialog()
.activeDataSet <- ActiveDataSet()
.activeModel <- ActiveModel()
formula1 <- justDoIt(paste("formula(",.activeModel, ")", sep=""))
if(logen){
doItAndPrint(paste("mixture.contour(", .activeDataSet, ", ", paste(formula1[2],formula1[1],formula1[3],sep=" "), ", n.tick=", n.ticks, ", n.grade=", n.grade,", FUN='exp', FUN2='log', mix.format='",mix.format,"', show.points=",show.points,", zoomed=",zoomed,ifelse(show.points,", pch=21, cex=1.25, col.points='black', fill.points='white'",""),")", sep=""))
} else {
doItAndPrint(paste("mixture.contour(", .activeDataSet, ", ", paste(formula1[2],formula1[1],formula1[3],sep=" "), ", n.tick=", n.ticks, ", n.grade=", n.grade,", mix.format='",mix.format,"', show.points=",show.points,", zoomed=",zoomed,ifelse(show.points,", pch=21, cex=1.25, col.points='black', fill.points='white'",""),")", sep=""))
}
tkfocus(CommanderWindow())
}
# Set up GUI
OKCancelHelp(helpSubject="lm")
combo <- ttkcombobox(comboFrame, values=as.character(2:10), textvariable=comboVar, width=3)
combo2 <- ttkcombobox(comboFrame2, values=as.character(seq(5,25,5)), textvariable=comboVar2, width=3)
tkgrid(labelRcmdr(comboFrame, text=gettextRcmdr("Plot ticks (default=6):")), combo, sticky="w")
tkgrid(labelRcmdr(comboFrame2, text=gettextRcmdr("Plot gradings (approximate, default=15):")), combo2, sticky="w")
tkgrid(comboFrame, sticky="w", column=1, row=1, columnspan=1)
tkgrid(comboFrame2, sticky="w", column=1, row=2, columnspan=1)
checkBoxes(frame="logFrame", boxes=c("log"), initialValues=c("0"),
labels=gettextRcmdr(c("log transformed response")))
tkgrid(logFrame, row=3, column=1, columnspan=1, rowspan=1, sticky="w")
radioButtonsUMB(formatFrame,name="label.format", buttons=c("frac", "dec"), values=c("frac", "dec"), initialValue = "frac",
labels=gettextRcmdr(c("Fraction", "Decimal")))
tkgrid(formatFrame, row=4, column=1, columnspan=1, rowspan=1, sticky="w")
checkBoxes(frame="zoomFrame", boxes=c("samples","zoomed"), initialValues=c("0"), labels=gettextRcmdr(c("Show samples", "Zoom on samples")))
tkgrid(zoomFrame, row=5, column=1, columnspan=1, rowspan=1, sticky="w")
tkgrid(buttonsFrame, sticky="w", row=6, column=1, columnspan=1)
dialogSuffix(rows=6, columns=1)
}
#####################################
# ANOVA for regression
anova_reg_GUI <- function(){
doItAndPrint(paste("anova_reg(", ActiveModel(), ")", sep=""))
}
#####################################
# PRESS
PRESS.GUI <- function(){
doItAndPrint(paste("PRESS(", ActiveModel(), ")", sep=""))
doItAndPrint(paste("R2pred(", ActiveModel(), ")", sep=""))
doItAndPrint(paste("RMSEP(", ActiveModel(), ")", sep=""))
}
######################################
## Customized observation statistics
addObservationStatisticsUMB <- function(){
.activeModel <- ActiveModel()
if (is.null(.activeModel)) return()
addVariable <- function(name, type=NULL){
variable <- paste(name, ".", ifelse(is.null(type),"",paste(type,".",sep="")), .activeModel, sep="")
if (is.element(variable, .variables)) {
ans <- checkReplace(variable)
if (tclvalue(ans) == "no") return()
}
command <- paste(name, "(", .activeModel, ifelse(is.null(type),"",paste(", type='",type,"'",sep="")), ")", sep="")
if(is.matrix(justDoIt(command))){
justDoIt(paste(.activeDataSet, " <- cbind(", .activeDataSet ,", extend.colnames(", command,",'", variable, "'))", sep=""))
logger(paste(.activeDataSet, " <- cbind(", .activeDataSet ,", extend.colnames(", command,",'", variable, "'))", sep=""))
} else {
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(.commander)
return()
}
initializeDialog(title=gettextRcmdr("Add Observation Statistics to Data"))
.activeModel <- ActiveModel()
.activeDataSet <- ActiveDataSet()
.variables <- Variables()
obsNumberExists <- is.element("obsNumber", .variables)
activate1 <- c( checkMethod("fitted", .activeModel, default=TRUE, reportError=FALSE),
checkMethod("residuals", .activeModel, default=TRUE, reportError=FALSE))
activate2 <- c( checkMethod("hatvalues", .activeModel, reportError=FALSE),
TRUE, # dffits
checkMethod("cooks.distance", .activeModel, reportError=FALSE))
activate3 <- c( TRUE,TRUE) # stdres, studres
activate4 <- c( TRUE,TRUE) # pearson, spearson
activate5 <- c( TRUE, TRUE) # PRESS.res, PRESS.pred
checkBoxes(frame="selectFrame1", boxes=c(c("fitted", "residuals")[activate1]),
initialValues=c(rep(0, sum(activate1))),
labels=c(gettextRcmdr(c("Fitted values", "Residuals"))[activate1]))
checkBoxes(frame="selectFrame2", boxes=c(c("hatvalues", "dffits", "cookd")[activate2]),
initialValues=c(rep(0, sum(activate2))),
labels=c(gettextRcmdr(c("Hat-values", "DFFITS", "Cook's distances"))[activate2]))
checkBoxes(frame="selectFrame3", boxes=c(c("stdres", "studres")[activate3]),
initialValues=c(rep(0, sum(activate3)), "0"),
labels=c(gettextRcmdr(c("Standardized residuals", "Studentized residuals"))[activate3]))
checkBoxes(frame="selectFrame4", boxes=c(c("pearson", "spearson")[activate4]),
initialValues=c(rep(0, sum(activate4))),
labels=c(gettextRcmdr(c("Pearson residuals", "Standardized Pearson residuals"))[activate4]))
checkBoxes(frame="selectFrame5", boxes=c(c("pressres","presspred")[activate5]),
initialValues=c(rep(0, sum(activate5))),
labels=c(gettextRcmdr(c("CV residual", "CV predictions"))[activate5]))
checkBoxes(frame="selectFrame6", boxes=c("obsNumbers"),
initialValues=c("0"),
labels=c( gettextRcmdr("Observation indices")))
onOK <- function(){
closeDialog()
if (activate1[1] && tclvalue(fittedVariable) == 1) addVariable("fitted")
if (activate1[2] && tclvalue(residualsVariable) == 1) addVariable("residuals")
if (activate3[1] && tclvalue(stdresVariable) == 1) addVariable("stdres")
if (activate3[2] && tclvalue(studresVariable) == 1) addVariable("studres")
if (activate4[1] && tclvalue(pearsonVariable) == 1) addVariable("residuals","pearson")
if (activate4[2] && tclvalue(spearsonVariable) == 1) addVariable("spearson")
if (activate2[1] && tclvalue(hatvaluesVariable) == 1) addVariable("hatvalues")
if (activate2[2] && tclvalue(dffitsVariable) == 1) addVariable("dffits")
if (activate2[3] && tclvalue(cookdVariable) == 1) addVariable("cooks.distance")
if (activate5[1] && tclvalue(pressresVariable) == 1) addVariable("PRESS.res")
if (activate5[2] && tclvalue(presspredVariable) == 1) addVariable("PRESS.pred")
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)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="influence.measures")
tkgrid(selectFrame1, sticky="w", column=1, row=1, rowspan=2)
tkgrid(selectFrame2, sticky="w", column=1, row=4, rowspan=3)
tkgrid(selectFrame3, sticky="w", column=2, row=1, rowspan=2)
tkgrid(selectFrame4, sticky="w", column=2, row=4, rowspan=2)
tkgrid(selectFrame5, sticky="w", column=2, row=7, rowspan=2)
tkgrid(selectFrame6, sticky="w", column=1, row=8, rowspan=1)
spaceFrame1 <- tkframe(top)
tkgrid(labelRcmdr(spaceFrame1, text=gettextRcmdr(" ")), sticky="w")
tkgrid(spaceFrame1, sticky="w", row=3, column=1, columnspan=1)
spaceFrame2 <- tkframe(top)
tkgrid(labelRcmdr(spaceFrame2, text=gettextRcmdr(" ")), sticky="w")
tkgrid(spaceFrame2, sticky="w", row=3, column=2, columnspan=1)
spaceFrame3 <- tkframe(top)
tkgrid(labelRcmdr(spaceFrame3, text=gettextRcmdr(" ")), sticky="w")
tkgrid(spaceFrame3, sticky="w", row=6, column=2, columnspan=1)
spaceFrame4 <- tkframe(top)
tkgrid(labelRcmdr(spaceFrame4, text=gettextRcmdr(" ")), sticky="w")
tkgrid(spaceFrame4, sticky="w", row=7, column=1, columnspan=1)
tkgrid(buttonsFrame, sticky="w", row=9, column=1, columnspan=2)
dialogSuffix(rows=9, columns=1)
}
#####################################
# Goodness of fit tests
deviance_tests_GUI <- function(){
doItAndPrint("deviance_tests()")
}
#####################################
# (X'X)^-1 = solve(crossprod(X))
invXtXGUI <- function(){
initializeDialog(title=gettextRcmdr("Store and/or display (X'X)^-1 (inverse regressor covariance)"))
mainFrame <- tkframe(top)
onOK <- function(){ # Actions to perform
command <- paste("solve(crossprod(model.matrix(",ActiveModel(),")))",sep="")
stored <- tclvalue(storeVariable)
if(stored == gettextRcmdr("1")){
doItAndPrint(paste("invXtX <- ", command, sep=""))
}
displayed <- tclvalue(displayVariable)
if(displayed == gettextRcmdr("1")){
doItAndPrint(command)
}
closeDialog()
tkfocus(CommanderWindow())
}
# Set up GUI
OKCancelHelp(helpSubject="lm")
checkBoxes(frame="mainFrame", boxes=c("store","display"), initialValues=c("1","1"),
labels=gettextRcmdr(c("Store matrix as invXtX","Display matrix")))
tkgrid(mainFrame, row=1, column=1, columnspan=1, rowspan=1, sticky="w")
tkgrid(buttonsFrame, sticky="w", row=2, column=1, columnspan=1)
dialogSuffix(rows=2, columns=1)
}
Try the RcmdrPlugin.UMB package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.