Nothing
# $Id: NMBU.GUI.Statistics.R 35 2014-01-10 21:17:26Z khliland $
##
## GUI functions for the Statistics 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.
############################
# Covariance matrix
covarianceMatrix <- function(){
initializeDialog(title=gettextRcmdr("Covariance/correlation matrix")) # Window heading
initial.group <- NULL
# Prepare selection box and radio buttons
xBox <- variableListBox(top, Numeric(), selectmode="multiple", title=gettextRcmdr("Variables (pick two or more)"))
wBox <- variableListBox(top, c("-none-", Numeric()), selectmode="single", title=gettextRcmdr("Weights (pick zero or one)"))
radioButtons(name="covariances", buttons=c("pearson", "spearman"), values=c("Pearson", "Spearman"),
labels=gettextRcmdr(c("Pearson product-moment", "Spearman rank-order")), title=gettextRcmdr("Type (unweighted)"))
radioButtons(name="covCor", buttons=c("covariance", "correlation"), values=c("covariance", "correlation"),
labels=gettextRcmdr(c("Covariance", "Correlation")), title=gettextRcmdr("Output"))
groupsBox(recall=covarianceMatrix, label=gettextRcmdr("Compute by:"),
initialLabel=gettextRcmdr("Compute by groups"),
initialGroup=initial.group)
onOK <- function(){ # Actions to perform
covariances <- tclvalue(covariancesVariable)
covCor <- tclvalue(covCorVariable)
x <- getSelection(xBox)
w <- getSelection(wBox)
if (2 > length(x)) {
errorCondition(recall=covarianceMatrix, message=gettextRcmdr("Fewer than 2 variables selected."))
return()
}
closeDialog()
x <- paste('"', x, '"', sep="")
.activeDataSet <- ActiveDataSet()
if(.groups==FALSE){
if(length(w)>0 && w !="-none-"){
if(covCor=="correlation"){
doItAndPrint(paste("cov.wt(", .activeDataSet, "[,c(", paste(x, collapse=","),
")], wt=", .activeDataSet, "$", w ,", cor=TRUE)$cor", sep=""))
} else {
doItAndPrint(paste("cov.wt(", .activeDataSet, "[,c(", paste(x, collapse=","),
")], wt=", .activeDataSet, "$", w ,")$cov", sep=""))
}
} else {
type <- ifelse(covCor=="correlation","cor","cov")
if (covariances == "Pearson"){
doItAndPrint(paste(type, "(", .activeDataSet, "[,c(", paste(x, collapse=","),
')], use="complete.obs")', sep=""))
}
else if (covariances == "Spearman"){
logger("# Spearman rank-order covariances")
doItAndPrint(paste(type, "(", .activeDataSet, "[,c(", paste(x, collapse=","),
')], use="complete.obs", method="spearman")', sep=""))
}
}
} else {
eval(parse(text=paste(".levels <- levels(", .activeDataSet, "$", .groups, ")", sep="")))
for(i in 1:length(.levels)){
if(length(w)>0 && w !="-none-"){
if(covCor=="correlation"){
doItAndPrint(paste("cov.wt(", .activeDataSet, "[", .activeDataSet, "$", .groups, "=='", .levels[i] ,"',c(", paste(x, collapse=","),
")], wt=", .activeDataSet, "$", w ,"[", .activeDataSet, "$", .groups, "=='", .levels[i] ,"'], cor=TRUE)$cor", sep=""))
} else {
doItAndPrint(paste("cov.wt(", .activeDataSet, "[", .activeDataSet, "$", .groups, "=='", .levels[i] ,"',c(", paste(x, collapse=","),
")], wt=", .activeDataSet, "$", w ,"[", .activeDataSet, "$", .groups, "=='", .levels[i] ,"'])$cov", sep=""))
}
} else {
type <- ifelse(covCor=="correlation","cor","cov")
if (covariances == "Pearson"){
doItAndPrint(paste(type, "(", .activeDataSet, "[", .activeDataSet, "$", .groups, "=='", .levels[i] ,"',c(", paste(x, collapse=","),
')], use="complete.obs")', sep=""))
}
else if (covariances == "Spearman"){
logger("# Spearman rank-order covariances")
doItAndPrint(paste(type, "(", .activeDataSet, "[", .activeDataSet, "$", .groups, "=='", .levels[i] ,"',c(", paste(x, collapse=","),
')], use="complete.obs", method="spearman")', sep=""))
}
}
}
}
tkfocus(CommanderWindow())
}
# Set up GUI
OKCancelHelp(helpSubject="cov")
tkgrid(getFrame(xBox), sticky="nw", row=1, column=1)
tkgrid(getFrame(wBox), sticky="nw", row=1, column=2)
tkgrid(groupsFrame, sticky = "w", row=2, column=1)
tkgrid(covariancesFrame, sticky="w", row=3, column=1)
tkgrid(covCorFrame, sticky="w", row=3, column=2)
tkgrid(buttonsFrame, sticky="w", row=4, column=1, columnspan=2)
dialogSuffix(rows=4, columns=2)
}
####################################
# Proportion testing (two proportions) (without data)
twoProportionTest <- function(){
initializeDialog(title=gettextRcmdr("Two-Sample Proportion Test"))
onOK <- function(){ # Actions to perform
succ1 <- tclvalue(successLevel1)
succ2 <- tclvalue(successLevel2)
if(trim.blanks(succ1) == gettextRcmdr("") || trim.blanks(succ2) == gettextRcmdr("")){
errorCondition(recall=twoProportionTest, message=gettextRcmdr("Please specify the number of successes for both groups."))
return()
}
fail1 <- tclvalue(failureLevel1)
fail2 <- tclvalue(failureLevel2)
if(trim.blanks(fail1) == gettextRcmdr("") || trim.blanks(fail2) == gettextRcmdr("")){
errorCondition(recall=twoProportionTest, message=gettextRcmdr("Please specify the number of failures for both groups."))
return()
}
alternative <- as.character(tclvalue(alternativeVariable))
level <- tclvalue(confidenceLevel)
test <- as.character(tclvalue(testVariable))
testVer <- as.character(tclvalue(testVerVariable))
closeDialog()
command <- paste(".Table <- cbind(successes=c(", succ1, ",", succ2, "), failures=c(", fail1, ",", fail2, "))", sep="")
# logger(command)
# assign(".Table", justDoIt(command), envir=.GlobalEnv)
doItAndPrint(command)
doItAndPrint(".Table")
if(testVer=="pooled"){
pooled <- "TRUE)"
} else {
pooled <- "FALSE)"
}
if (test == "normal") doItAndPrint(paste("prop.test.ordinary(.Table, alternative='",
alternative, "', conf.level=", level, ", correct=FALSE, pooled=", pooled, sep=""))
else doItAndPrint(paste("prop.test.ordinary(.Table, alternative='",
alternative, "', conf.level=", level, ", correct=TRUE, pooled=", pooled, sep=""))
tkfocus(CommanderWindow())
}
# Set up GUI
successFrame <- tkframe(top)
successLevel1 <- tclVar("?")
successLevel2 <- tclVar("?")
successField1 <- ttkentry(successFrame, width="6", textvariable=successLevel1)
successField2 <- ttkentry(successFrame, width="6", textvariable=successLevel2)
failureFrame <- tkframe(top)
failureLevel1 <- tclVar("?")
failureLevel2 <- tclVar("?")
failureField1 <- ttkentry(failureFrame, width="6", textvariable=failureLevel1)
failureField2 <- ttkentry(failureFrame, width="6", textvariable=failureLevel2)
tkgrid(labelRcmdr(successFrame, text=gettextRcmdr("# of successes:"), fg="blue"), successField1, successField2, sticky="nw")
tkgrid(labelRcmdr(failureFrame, text=gettextRcmdr("# of failures:"), fg="blue"), failureField1, failureField2, sticky="nw")
tkgrid(successFrame, sticky="nw")
tkgrid(failureFrame, sticky="nw")
OKCancelHelp(helpSubject="prop.test")
radioButtons(top, name="alternative", buttons=c("twosided", "less", "greater"), values=c("two.sided", "less", "greater"),
labels=gettextRcmdr(c("Two-sided", "Difference < 0", "Difference > 0")), title=gettextRcmdr("Alternative Hypothesis"))
rightFrame <- tkframe(top)
confidenceFrame <- tkframe(rightFrame)
confidenceLevel <- tclVar(".95")
confidenceField <- ttkentry(confidenceFrame, width="6", textvariable=confidenceLevel)
radioButtons(name="test", buttons=c("normal", "corrected"),
labels=gettextRcmdr(c("Normal approximation", "Normal approximation with\ncontinuity correction")),
title=gettextRcmdr("Type of Test"))
radioButtons(name="testVer", buttons=c("pooled", "individual"),
labels=gettextRcmdr(c("Pooled sample proportion", "Individual sample proportions")),
title=gettextRcmdr("Approximation version"))
tkgrid(labelRcmdr(rightFrame, text=""))
tkgrid(labelRcmdr(confidenceFrame, text=gettextRcmdr("Confidence Level: "), fg="blue"), confidenceField, sticky="nw")
tkgrid(confidenceFrame, sticky="nw")
tkgrid(alternativeFrame, rightFrame, sticky="nw")
tkgrid(testFrame, testVerFrame, sticky="nw")
tkgrid(buttonsFrame, columnspan=2, sticky="nw")
tkgrid.configure(confidenceField, sticky="e")
dialogSuffix(rows=4, columns=2)
}
####################################
# Proportion testing (without data)
proportionTest <- function(){
initializeDialog(title=gettextRcmdr("Single-Sample Proportion Test"))
onOK <- function(){ # Actions to perform
succ <- tclvalue(successLevel)
if(trim.blanks(succ) == gettextRcmdr("")){
errorCondition(recall=proportionTest, message=gettextRcmdr("Please specify the number of successes."))
return()
}
fail <- tclvalue(failureLevel)
if(trim.blanks(fail) == gettextRcmdr("")){
errorCondition(recall=proportionTest, message=gettextRcmdr("Please specify the number of failures."))
return()
}
alternative <- as.character(tclvalue(alternativeVariable))
level <- tclvalue(confidenceLevel)
test <- as.character(tclvalue(testVariable))
testVer <- as.character(tclvalue(testVerVariable))
p <- tclvalue(pVariable)
closeDialog()
command <- paste(".Table <- cbind(successes=", succ, ", failures=", fail, ")", sep="")
# logger(command)
# assign(".Table", justDoIt(command), envir=.GlobalEnv)
doItAndPrint(command)
doItAndPrint(".Table")
if(testVer=="ordinaryVer"){
the.prop <- "prop.test.ordinary"
} else {
the.prop <- "prop.test"
}
if (test == "normal") doItAndPrint(paste(the.prop, "(.Table, alternative='",
alternative, "', p=", p, ", conf.level=", level, ", correct=FALSE)", sep=""))
else if (test == "corrected") doItAndPrint(paste(the.prop, "(.Table, alternative='",
alternative, "', p=", p, ", conf.level=", level, ", correct=TRUE)", sep=""))
else doItAndPrint(paste("binom.test(.Table, alternative='",
alternative, "', p=", p, ", conf.level=", level, ")", sep=""))
tkfocus(CommanderWindow())
}
# Set up GUI
successFrame <- tkframe(top)
successLevel <- tclVar("?")
successField <- ttkentry(successFrame, width="6", textvariable=successLevel)
failureFrame <- tkframe(top)
failureLevel <- tclVar("?")
failureField <- ttkentry(failureFrame, width="6", textvariable=failureLevel)
tkgrid(labelRcmdr(successFrame, text=gettextRcmdr("# of successes:"), fg="blue"), successField, sticky="nw")
tkgrid(labelRcmdr(failureFrame, text=gettextRcmdr("# of failures:"), fg="blue"), failureField, sticky="nw")
tkgrid(successFrame, sticky="nw")
tkgrid(failureFrame, sticky="nw")
OKCancelHelp(helpSubject="prop.test")
radioButtons(top, name="alternative", buttons=c("twosided", "less", "greater"), values=c("two.sided", "less", "greater"),
labels=gettextRcmdr(c("Population proportion != p0", "Population proportion < p0", "Population proportion > p0")), title=gettextRcmdr("Alternative Hypothesis"))
rightFrame <- tkframe(top)
confidenceFrame <- tkframe(rightFrame)
confidenceLevel <- tclVar(".95")
confidenceField <- ttkentry(confidenceFrame, width="6", textvariable=confidenceLevel)
pFrame <- tkframe(rightFrame)
pVariable <- tclVar(".5")
pField <- ttkentry(pFrame, width="6", textvariable=pVariable)
radioButtons(name="test", buttons=c("normal", "corrected", "exact"),
labels=gettextRcmdr(c("Normal approximation", "Normal approximation with\ncontinuity correction", "Exact binomial")),
title=gettextRcmdr("Type of Test"))
radioButtons(name="testVer", buttons=c("ordinaryVer", "wilsonVer"),
labels=gettextRcmdr(c("Ordinary (textbook default)", "Wilson score (R default)")),
title=gettextRcmdr("Approximation version"))
tkgrid(labelRcmdr(pFrame, text=gettextRcmdr("Null hypothesis: p = "), fg="blue"), pField, sticky="nw")
tkgrid(pFrame, sticky="nw")
tkgrid(labelRcmdr(rightFrame, text=""))
tkgrid(labelRcmdr(confidenceFrame, text=gettextRcmdr("Confidence Level: "), fg="blue"), confidenceField, sticky="nw")
tkgrid(confidenceFrame, sticky="nw")
tkgrid(alternativeFrame, rightFrame, sticky="nw")
tkgrid(testFrame, testVerFrame, sticky="nw")
tkgrid(buttonsFrame, columnspan=2, sticky="nw")
tkgrid.configure(confidenceField, sticky="e")
dialogSuffix(rows=4, columns=2)
}
##################################
# Partial least squares (and PCR)
plsRegressionModel <- function(){
initializeDialog(title=gettextRcmdr("Multivariate regression"))
variablesFrame1 <- tkframe(top)
variablesFrame2 <- tkframe(top)
.numeric <- Numeric()
.variable <- Variables()
xBox <- variableListBox(variablesFrame1, .numeric, selectmode="multiple",
title=gettextRcmdr("Explanatory variables (pick one or more)"))
yBox <- variableListBox(variablesFrame2, .variable, title=gettextRcmdr("Response variable (pick one)"))
UpdateModelNumber()
modelName <- tclVar(paste("MVRModel.", getRcmdr("modelNumber"), sep=""))
modelFrame <- tkframe(top)
model <- ttkentry(modelFrame, width="20", textvariable=modelName)
subsetBox()
compFrame <- tkframe(top)
compVar <- tclVar("3")
compEntry <- ttkentry(compFrame, width="3", textvariable=compVar)
onOK <- function(){ # Actions to perform
x <- getSelection(xBox)
y <- getSelection(yBox)
closeDialog()
if (0 == length(y)) {
UpdateModelNumber(-1)
errorCondition(recall=plsRegressionModel, message=gettextRcmdr("You must select a response variable."))
return()
}
if (0 == length(x)) {
UpdateModelNumber(-1)
errorCondition(recall=plsRegressionModel, message=gettextRcmdr("No explanatory variables selected."))
return()
}
if (is.element(y, x)) {
UpdateModelNumber(-1)
errorCondition(recall=plsRegressionModel, message=gettextRcmdr("Response and explanatory variables must be different."))
return()
}
subset <- tclvalue(subsetVariable)
if (trim.blanks(subset) == gettextRcmdr("<all valid cases>") || trim.blanks(subset) == ""){
subset <- ""
putRcmdr("modelWithSubset", FALSE)
}
else{
subset <- paste(", subset=", subset, sep="")
putRcmdr("modelWithSubset", TRUE)
}
ncomp <- tclvalue(compVar)
if(trim.blanks(ncomp) == gettextRcmdr("")){
ncomp <- 1
warning('Number of components must be specified')
}
modelValue <- trim.blanks(tclvalue(modelName))
if (!is.valid.name(modelValue)){
UpdateModelNumber(-1)
errorCondition(recall=plsRegressionModel, message=sprintf(gettextRcmdr('"%s" is not a valid name.'), modelValue))
return()
}
if (is.element(modelValue, listLinearModels())) {
if ("no" == tclvalue(checkReplace(modelValue, type=gettextRcmdr("Model")))){
UpdateModelNumber(-1)
plsRegressionModel()
return()
}
}
validation <- as.character(tclvalue(validationVariable))
if(validation == gettextRcmdr("LOO"))
validate <- ", validation='LOO'"
else {
if(validation == gettextRcmdr("none"))
validate <- ""
else
validate <- paste(", validation='CV', segments=", validation, sep="")
}
jackknife <- tclvalue(jackknifeVariable)
if(jackknife == gettextRcmdr("1")){
validate <- paste(validate, ", jackknife=TRUE", sep="")
if(validation == gettextRcmdr("none")){
UpdateModelNumber(-1)
errorCondition(recall=plsRegressionModel, message=gettextRcmdr("Cannot perform jackknife without cross-validation."))
return()
}
}
pcrpls <- as.character(tclvalue(pcrplsrVariable))
.the.y <- justDoIt(paste(".the.y <- ", ActiveDataSet(), "$", y, sep=""))
if(is.factor(.the.y)){
.the.new.y <- justDoIt(".the.new.y <- matrix(0, length(.the.y), length(levels(.the.y))-1)")
for(i in 1:(length(levels(.the.y))-1)){
.the.new.y[,i] <- justDoIt(paste(".the.new.y[,", i, "] <- (.the.y==levels(.the.y)[", i, "])*1",sep=""))
}
justDoIt(paste(ActiveDataSet(), "$", y, " <- .the.new.y", sep=""))
}
command <- paste(pcrpls, "(", y, "~", paste(x, collapse="+"),
", data=", ActiveDataSet(), subset, ", ncomp=", as.numeric(ncomp), validate, ")", sep="")
# logger(paste(modelValue, " <- ", command, sep=""))
# assign(modelValue, justDoIt(command), envir=.GlobalEnv)
doItAndPrint(paste(modelValue, " <- ", command, sep=""))
if(is.factor(.the.y)){
justDoIt(paste(ActiveDataSet(), "$", y, " <- .the.y", sep=""))
justDoIt("rm('.the.new.y')")
doItAndPrint("#Dummy response")
}
justDoIt("rm('.the.y')")
doItAndPrint(paste("summary(", modelValue, ")", sep=""))
addComp <- tclvalue(addCompVariable)
if (addComp == "1") {
initializeDialog(subdialog, title=gettextRcmdr("Number of components"))
tkgrid(labelRcmdr(subdialog, text=gettextRcmdr("Number of components to retain:"), fg="blue"), sticky="w")
sliderFrame <- tkframe(subdialog)
sliderValue <- tclVar("1")
componentsSlider <- tkscale(sliderFrame, from=1, to=ncomp, showvalue=FALSE, variable=sliderValue,
resolution=1, orient="horizontal")
componentsShow <- labelRcmdr(sliderFrame, textvariable=sliderValue, width=2, justify="right")
onOKsub <- function() {
closeDialog(subdialog)
putRcmdr("ncomponents", as.numeric(tclvalue(sliderValue)))
}
subOKCancelHelp()
tkgrid(componentsSlider, componentsShow, sticky="nw")
tkgrid(sliderFrame, sticky="w")
tkgrid(subButtonsFrame, sticky="w")
dialogSuffix(subdialog, onOK=onOKsub, rows=2, columns=1, focus=subdialog)
if ((ncomponents <- getRcmdr("ncomponents")) > 0){
for(i in 1:ncomponents){
var <- paste("Comp", i, sep="")
if (is.element(var, Variables())) {
if ("no" == tclvalue(checkReplace(var))) next
}
justDoIt(paste(.activeDataSet, "$Comp", i, " <- scores(", modelValue, ")[,", i, "]", sep=""))
logger(paste(.activeDataSet, "$Comp", i, " <- scores(", modelValue, ")[,", i, "]", sep=""))
}
activeDataSet(.activeDataSet)
}
}
activeModel(modelValue)
tkfocus(CommanderWindow())
}
# Set up GUI
OKCancelHelp(helpSubject="mvr", model=TRUE)
tkgrid(labelRcmdr(modelFrame, text=gettextRcmdr("Enter name for model:")), model, sticky="w")
tkgrid(modelFrame, row=1, column=1, columnspan=2, sticky="n")
tkgrid(getFrame(yBox), labelRcmdr(variablesFrame2, text=" "), sticky="nw")
tkgrid(getFrame(xBox), sticky="nw")
tkgrid(variablesFrame2, sticky="w", row=2, column=1)
tkgrid(variablesFrame1, sticky="w", row=2, column=2)
tkgrid(subsetFrame, row=3, column=1, sticky="w")
tkgrid(labelRcmdr(compFrame, text=gettextRcmdr("Number of components")), compEntry, sticky="w")
tkgrid(compFrame, row=3, column=2, sticky="w")
radioButtons(name="validation", buttons=c("none", "LOO", "CV10", "CV5"), values=c("none", "LOO", "10", "5"),
labels=gettextRcmdr(c("None", "Leave-one-out", "10-fold", "5-fold")), title=gettextRcmdr("Cross validation"))
tkgrid(validationFrame, row=4, column=1, rowspan=2, columnspan=1, sticky="w")
radioButtons(name="pcrplsr", buttons=c("pcr", "pls", "cppls"), values=c("pcr", "plsr", "cppls"), initialValue = "plsr",
labels=gettextRcmdr(c("Principal components", "Partial least squares", "Canonical PLS")), title=gettextRcmdr("Type of regression"))
tkgrid(pcrplsrFrame, row=4, column=2, rowspan=1, columnspan=1, sticky="w")
checkBoxes(frame="optionsFrame", boxes=c("jackknife","addComp"), initialValues=c("0","0"),
labels=gettextRcmdr(c("Jackknifing","Add scores to data set")))
tkgrid(optionsFrame, row=5, column=2, columnspan=1, sticky="w")
tkgrid(buttonsFrame, row=6, column=1, columnspan=2, stick="s")
tkgrid.configure(helpButton, sticky="se")
dialogSuffix(rows=6, columns=2)
}
########################
## Principal components
principalComponentsStat <- function(){
initializeDialog(title=gettextRcmdr("Principal Components Analysis (JW)"))
UpdateModelNumber()
modelName <- tclVar(paste("PCAModel.", getRcmdr("modelNumber"), sep=""))
modelFrame <- tkframe(top)
model <- ttkentry(modelFrame, width="20", textvariable=modelName)
xBox <- variableListBox(top, Numeric(), selectmode="multiple", title=gettextRcmdr("Variables (pick two or more)"))
subsetBox()
checkBoxes(frame="optionsFrame", boxes=c("center", "correlations", "screeplot", "addPC"), initialValues=c("1", "1", "0", "0"),
labels=gettextRcmdr(c("Center predictors", "Analyze correlation matrix", "Screeplot", "Add principal components to data set")))
onOK <- function(){ # Actions to perform
putRcmdr("ncomponents", 0)
x <- getSelection(xBox)
nvar <- length(x)
center <- tclvalue(centerVariable)
correlations <- tclvalue(correlationsVariable)
subset <- tclvalue(subsetVariable)
screeplot <- tclvalue(screeplotVariable)
addPC <- tclvalue(addPCVariable)
closeDialog()
if (2 > length(x)) {
errorCondition(recall=principalComponents, message=gettextRcmdr("Fewer than 2 variables selected."))
return()
}
modelValue <- trim.blanks(tclvalue(modelName))
if (!is.valid.name(modelValue)){
UpdateModelNumber(-1)
errorCondition(recall=principalComponents, message=sprintf(gettextRcmdr('"%s" is not a valid name.'), modelValue))
return()
}
if (is.element(modelValue, listLinearModels())) {
if ("no" == tclvalue(checkReplace(modelValue, type=gettextRcmdr("Model")))){
UpdateModelNumber(-1)
principalComponents()
return()
}
}
subset <- if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) "" else paste(", subset=", subset, sep="")
correlations <- if (correlations == "1") "TRUE" else "FALSE"
.activeDataSet <- ActiveDataSet()
if(center == "1"){
command <- paste("prcomp(~", paste(x, collapse="+"), ", center=TRUE, scale.=", correlations,
", data=", .activeDataSet, subset, ")", sep="")
}
else {
command <- paste("prcomp(~", paste(x, collapse="+"), ", center=FALSE, scale.=", correlations,
", data=", .activeDataSet, subset, ")", sep="")
}
# assign(modelValue, justDoIt(command), envir=.GlobalEnv)
# logger(paste(modelValue," <- ", command, sep=""))
doItAndPrint(paste(modelValue," <- ", command, sep=""))
doItAndPrint(paste("unclass(loadings(", modelValue, ")) # component loadings"))
doItAndPrint(paste(modelValue,"$sdev^2 # component variances"))
doItAndPrint(paste("summary(", modelValue, ") # proportions of variance"))
activeModel(modelValue)
if (screeplot == "1") {
justDoIt(paste("screeplot(", modelValue, ")"))
logger(paste("screeplot(", modelValue, ")"))
}
if (addPC == "1") {
initializeDialog(subdialog, title=gettextRcmdr("Number of Components"))
tkgrid(labelRcmdr(subdialog, text=gettextRcmdr("Number of components to retain:"), fg="blue"), sticky="w")
sliderFrame <- tkframe(subdialog)
sliderValue <- tclVar("1")
componentsSlider <- tkscale(sliderFrame, from=1, to=nvar, showvalue=FALSE, variable=sliderValue,
resolution=1, orient="horizontal")
componentsShow <- labelRcmdr(sliderFrame, textvariable=sliderValue, width=2, justify="right")
onOKsub <- function() {
closeDialog(subdialog)
putRcmdr("ncomponents", as.numeric(tclvalue(sliderValue)))
}
subOKCancelHelp()
tkgrid(componentsSlider, componentsShow, sticky="nw")
tkgrid(sliderFrame, sticky="w")
tkgrid(subButtonsFrame, sticky="w")
dialogSuffix(subdialog, onOK=onOKsub, rows=2, columns=1, focus=subdialog)
if ((ncomponents <- getRcmdr("ncomponents")) > 0){
for(i in 1:ncomponents){
var <- paste("PC", i, sep="")
if (is.element(var, Variables())) {
if ("no" == tclvalue(checkReplace(var))) next
}
justDoIt(paste(.activeDataSet, "$PC", i, " <- scores(", modelValue, ")[,", i, "]", sep=""))
logger(paste(.activeDataSet, "$PC", i, " <- scores(", modelValue, ")[,", i, "]", sep=""))
}
activeDataSet(.activeDataSet)
}
}
activeModel(modelValue)
tkfocus(CommanderWindow())
}
# Set up GUI
OKCancelHelp(helpSubject="prcomp")
tkgrid(labelRcmdr(modelFrame, text=gettextRcmdr("Enter name for model:")), model, sticky="w")
tkgrid(modelFrame, sticky="n")
tkgrid(getFrame(xBox), sticky="nw")
tkgrid(subsetFrame, sticky="w")
tkgrid(optionsFrame, sticky="w")
tkgrid(buttonsFrame, sticky="w")
dialogSuffix(rows=4, columns=1)
}
#########################################
# Linear/quadratic discriminant analysis
discriminantAnalysis <- function(){
initializeDialog(title=gettextRcmdr("Discriminant analysis"))
UpdateModelNumber()
modelName <- tclVar(paste("DAModel.", getRcmdr("modelNumber"), sep=""))
modelFrame <- tkframe(top)
model <- ttkentry(modelFrame, width="20", textvariable=modelName)
variablesFrame <- tkframe(top)
.numeric <- Numeric()
.factors <- Factors()
xBox <- variableListBox(variablesFrame, .numeric, selectmode="multiple",
title=gettextRcmdr("Explanatory variables (pick one or more)"))
yBox <- variableListBox(variablesFrame, .factors, title=gettextRcmdr("Response variable (pick one)"))
cvFrame <- tkframe(top)
priorFrame <- tkframe(top)
predFrame <- tkframe(top)
postFrame <- tkframe(top)
subsetBox()
onOK <- function(){ # Actions to perform
x <- getSelection(xBox)
y <- getSelection(yBox)
closeDialog()
if (0 == length(y)) {
UpdateModelNumber(-1)
errorCondition(recall=discriminantAnalysis, message=gettextRcmdr("You must select a response variable."))
return()
}
if (0 == length(x)) {
UpdateModelNumber(-1)
errorCondition(recall=discriminantAnalysis, message=gettextRcmdr("No explanatory variables selected."))
return()
}
if (is.element(y, x)) {
UpdateModelNumber(-1)
errorCondition(recall=discriminantAnalysis, message=gettextRcmdr("Response and explanatory variables must be different."))
return()
}
modelValue <- trim.blanks(tclvalue(modelName))
if (!is.valid.name(modelValue)){
UpdateModelNumber(-1)
errorCondition(recall=discriminantAnalysis, message=sprintf(gettextRcmdr('"%s" is not a valid name.'), modelValue))
return()
}
if (is.element(modelValue, listLinearModels())) {
if ("no" == tclvalue(checkReplace(modelValue, type=gettextRcmdr("Model")))){
UpdateModelNumber(-1)
discriminantAnalysis()
return()
}
}
the.subset <- tclvalue(subsetVariable)
if (trim.blanks(the.subset) == gettextRcmdr("<all valid cases>") || trim.blanks(the.subset) == ""){
subset <- ""
the.subset <- ""
putRcmdr("modelWithSubset", FALSE)
}
else{
subset <- paste(", subset=", the.subset, sep="")
putRcmdr("modelWithSubset", TRUE)
}
linQuad <- as.character(tclvalue(linQuadVariable))
if(linQuad == gettextRcmdr("linear")){
command <- paste("lda(", y, "~", paste(x, collapse="+"),
", data=", ActiveDataSet(), subset, "", sep="")
}
else{
command <- paste("qda(", y, "~", paste(x, collapse="+"),
", data=", ActiveDataSet(), subset, "", sep="")
}
prior <- as.character(tclvalue(priorVariable))
if(prior == gettextRcmdr("equal")){
try(eval(parse(text=paste("g <- length(levels(", ActiveDataSet(), "$", y, "))", sep=""))))
command <- paste(command, ", prior=rep(", 1/g, ",", g, ")", sep="")
}
the.cv <- tclvalue(cvVariable)
if(the.cv == gettextRcmdr("1")){
command.cv <- paste(command, ", CV=TRUE)", sep="")
command <- paste(command, ")", sep="")
}
else {
command <- paste(command, ")", sep="")
}
# assign(modelValue, justDoIt(command), envir=.GlobalEnv)
# logger(paste(modelValue," <- ", command, sep=""))
doItAndPrint(paste(modelValue," <- ", command, sep=""))
if(the.cv == gettextRcmdr("0")){
doItAndPrint(paste("confusion(", ActiveDataSet(), "$", y, "[", the.subset, "]", ", predict(", modelValue, ")$class) # confusion matrix", sep=""))
}
else {
doItAndPrint(paste("confusion(", ActiveDataSet(), "$", y, ", ", command.cv, "$class) # confusion matrix", sep=""))
}
the.predDisp <- as.character(tclvalue(displayPredVariable))
the.predSave <- as.character(tclvalue(savePredVariable))
if(the.predDisp == gettextRcmdr("1")){
if(the.cv == gettextRcmdr("0")){
doItAndPrint(paste("predict(", modelValue, ")$class # Predicted classes", sep=""))
}
else {
doItAndPrint(paste(command.cv, "$class # Predicted classes", sep=""))
}
}
if(the.predSave == gettextRcmdr("1")){
.activeDataSet <- ActiveDataSet()
if(the.cv == gettextRcmdr("0")){
justDoIt(paste(.activeDataSet, "$DA.class <- predict(", modelValue, ")$class", sep=""))
logger(paste(.activeDataSet, "$DA.class <- predict(", modelValue, ")$class", sep=""))
}
else {
justDoIt(paste(.activeDataSet, "$DA.class <- ", command.cv, "$class", sep=""))
logger(paste(.activeDataSet, "$DA.class <- ", command.cv, "$class", sep=""))
}
activeDataSet(.activeDataSet)
}
the.postDisp <- as.character(tclvalue(displayPostVariable))
the.postSave <- as.character(tclvalue(savePostVariable))
if(the.postDisp == gettextRcmdr("1")){
if(the.cv == gettextRcmdr("0")){
doItAndPrint(paste("predict(", modelValue, ")$posterior # Posterior probabilities", sep=""))
}
else {
doItAndPrint(paste(command.cv, "$posterior # Posterior probabilities", sep=""))
}
}
if(the.postSave == gettextRcmdr("1")){
.activeDataSet <- ActiveDataSet()
if(the.cv == gettextRcmdr("0")){
justDoIt(paste(.activeDataSet, "$DA.posterior <- predict(", modelValue, ")$posterior", sep=""))
logger(paste(.activeDataSet, "$DA.posterior <- predict(", modelValue, ")$posterior", sep=""))
}
else {
justDoIt(paste(.activeDataSet, "$DA.posterior <- ", command.cv, "$posterior", sep=""))
logger(paste(.activeDataSet, "$DA.posterior <- ", command.cv, "$posterior", sep=""))
}
activeDataSet(.activeDataSet)
}
activeModel(modelValue)
tkfocus(CommanderWindow())
}
# Set up GUI
OKCancelHelp(helpSubject="lda")
tkgrid(labelRcmdr(modelFrame, text=gettextRcmdr("Enter name for model:")), model, sticky="w")
tkgrid(modelFrame, row=1, column=1, columnspan=2, sticky="n")
tkgrid(getFrame(yBox), labelRcmdr(variablesFrame, text=" "), getFrame(xBox), sticky="nw")
tkgrid(variablesFrame, sticky="w", row=2, column=1, columnspan=2)
tkgrid(subsetFrame, sticky="w", row=3, column=1, columnspan=1, rowspan=1)
checkBoxes(frame="cvFrame", boxes=c("cv"), initialValues=c("0"),
labels=gettextRcmdr(c("Cross-validation (LOO)")))
tkgrid(cvFrame, row=3, column=2, columnspan=1, sticky="w")
radioButtons(name="linQuad", buttons=c("Linear", "Quadratic"), values=c("linear", "quadratic"),
labels=gettextRcmdr(c("Linear", "Quadratic")), title=gettextRcmdr("Type"))
tkgrid(linQuadFrame, row=4, column=1, columnspan=1, sticky="w")
radioButtons(name="prior", buttons=c("Empirical", "Equal"), values=c("emprirical", "equal"),
labels=gettextRcmdr(c("Empirical", "Equal")), title=gettextRcmdr("Priors"))
tkgrid(priorFrame, row=4, column=2, columnspan=1, sticky="w")
checkBoxes(frame="predFrame", boxes=c("displayPred","savePred"), initialValues=c("0","0"),
labels=gettextRcmdr(c("Display predictions","Save predictions")))
tkgrid(predFrame, row=5, column=1, columnspan=1, sticky="w")
checkBoxes(frame="postFrame", boxes=c("displayPost","savePost"), initialValues=c("0","0"),
labels=gettextRcmdr(c("Display post. prob.","Save post. prob.")))
tkgrid(postFrame, row=5, column=2, columnspan=1, sticky="w")
tkgrid(buttonsFrame, row=6, column=1, columnspan=2, stick="w")
tkgrid.configure(helpButton, sticky="e")
dialogSuffix(rows=6, columns=2)
}
###################################################
# Hierarchical clustering of variables
hierarchicalClusterVariable <- function(){
solutionNumber=length(listHclustSolutions())
initializeDialog(title=gettextRcmdr("Hierarchical Clustering of Variables"))
solutionFrame <- tkframe(top)
solutionName <- tclVar(paste("HClust.", (solutionNumber+1),
sep=""))
solutionField <- ttkentry(solutionFrame, width="20",
textvariable=solutionName)
dataFrame <- tkframe(top)
xBox <- variableListBox(dataFrame, Numeric(), selectmode="multiple",
title=gettextRcmdr("Variables (pick one or more)"))
subsetBox(dataFrame)
radioButtons(name="method",
buttons=c("ward", "single", "complete","average", "mcquitty", "median",
"centroid"), labels=gettextRcmdr(c("Ward's Method", "Single Linkage",
"Complete Linkage", "Average Linkage", "McQuitty's Method",
"Median Linkage", "Centroid Linkage")), title=gettextRcmdr("Clustering Method"))
optionsFrame <- tkframe(top)
radioButtons(optionsFrame, name="distanceType", buttons=c("cor1", "cor2"),
labels=gettextRcmdr(c("Correlation", "Absolute correlation")), title=gettextRcmdr("Distance Measure"))
checkFrame <- tkframe(optionsFrame)
plotDendro <- tclVar("1")
plotCB <- tkcheckbutton(checkFrame)
tkconfigure(plotCB, variable=plotDendro)
onOK <- function(){ # Actions to perform
x <- getSelection(xBox)
nvar <- length(x)
clusMethod <- tclvalue(methodVariable)
distance <- tclvalue(distanceTypeVariable)
subset <- trim.blanks(tclvalue(subsetVariable))
dendro <- tclvalue(plotDendro)
solution <- trim.blanks(tclvalue(solutionName))
if (length(x)==0) {
errorCondition(recall=hierarchicalCluster,
message=gettextRcmdr("No variables selected."))
return()
}
closeDialog()
varFormula <- paste(x, collapse="+")
vars <- paste(x, collapse=",", sep="")
.activeDataSet <- ActiveDataSet()
dset <- if (subset == gettextRcmdr("<all valid cases>")) .activeDataSet
else {paste(.activeDataSet, "[", .activeDataSet, "$", subset, ", ]",
sep="")}
xmat <- paste("model.matrix(~-1 + ", varFormula, ", ", dset, ")",
sep="")
if(distance=="cor1") {
dx <- paste("as.dist(1-cor(", xmat, "))", sep="")
distlab <- "correlation"
}
else {
dx <- paste("as.dist(1-abs(cor(", xmat, ")))", sep="")
distlab <- "absolute correlation"
}
command <- paste("hclust(", dx, " , method= ", '"', clusMethod, '"',
")", sep="")
# assign(solution, justDoIt(command), envir=.GlobalEnv)
# logger(paste(solution, " <- ", command, sep=""))
doItAndPrint(paste(solution, " <- ", command, sep=""))
if (dendro == "1") {
justDoIt(paste("plot(", solution, ", main= ",'"',
"Cluster Dendrogram for Solution ", solution, '"', ", xlab= ",
'"',"Observation Number in Data Set ", dset, '"',
", sub=", '"', "Method=", clusMethod,
"; Distance=", distlab, '"', ")", sep=""))
logger(paste("plot(", solution, ", main= ",'"',
"Cluster Dendrogram for Solution ", solution, '"', ", xlab= ",
'"',"Observation Number in Data Set ", dset, '"',
", sub=", '"', "Method=", clusMethod,
"; Distance=", distlab, '"', ")",
sep=""))
}
activateMenus()
tkfocus(CommanderWindow())
}
# Set up GUI
OKCancelHelp(helpSubject="hclust")
tkgrid(solutionField, sticky="w")
tkgrid(labelRcmdr(top, text=gettextRcmdr("Clustering solution name:")),
solutionFrame, sticky="w")
tkgrid(getFrame(xBox), sticky="nw")
tkgrid(subsetFrame, sticky="w")
tkgrid(distanceTypeFrame, sticky="w")
tkgrid(labelRcmdr(checkFrame, text=" "), sticky="w")
tkgrid(labelRcmdr(checkFrame, text=gettextRcmdr("Plot Dendrogram ")), plotCB,
sticky="w")
tkgrid(checkFrame, sticky="w")
tkgrid(dataFrame, methodFrame, optionsFrame, sticky="nw")
tkgrid(buttonsFrame, columnspan=3, sticky="w")
dialogSuffix(rows=3, columns=3)
}
############################
## Customized two-way table
enterTableNMBU <- function(){
env <- environment()
initializeDialog(title=gettextRcmdr("Enter Two-Way Table"))
outerTableFrame <- tkframe(top)
assign(".tableFrame", tkframe(outerTableFrame), envir=env)
setUpTable <- function(...){
tkdestroy(get(".tableFrame", envir=env))
assign(".tableFrame", tkframe(outerTableFrame), envir=env)
nrows <- as.numeric(tclvalue(rowsValue))
ncols <- as.numeric(tclvalue(colsValue))
make.col.names <- "labelRcmdr(.tableFrame, text='')"
for (j in 1:ncols) {
col.varname <- paste(".colname.", j, sep="")
assign(col.varname, tclVar(j), envir=env)
make.col.names <- paste(make.col.names, ", ", "ttkentry(.tableFrame, width='5', textvariable=",
col.varname, ")", sep="")
}
eval(parse(text=paste("tkgrid(", make.col.names, ")", sep="")), envir=env)
for (i in 1:nrows){
varname <- paste(".tab.", i, ".1", sep="")
assign(varname, tclVar("") , envir=env)
row.varname <- paste(".rowname.", i, sep="")
assign(row.varname, tclVar(i), envir=env)
make.row <- paste("ttkentry(.tableFrame, width='5', textvariable=",
row.varname, ")", sep="")
make.row <- paste(make.row, ", ", "ttkentry(.tableFrame, width='5', textvariable=",
varname, ")", sep="")
for (j in 2:ncols){
varname <- paste(".tab.", i, ".", j, sep="")
assign(varname, tclVar(""), envir=env)
make.row <- paste(make.row, ", ", "ttkentry(.tableFrame, width='5', textvariable=",
varname, ")", sep="")
}
eval(parse(text=paste("tkgrid(", make.row, ")", sep="")), envir=env)
}
tkgrid(get(".tableFrame", envir=env), sticky="w")
}
rowColFrame <- tkframe(top)
rowsValue <- tclVar("2")
rowsSlider <- tkscale(rowColFrame, from=2, to=10, showvalue=FALSE, variable=rowsValue,
resolution=1, orient="horizontal", command=setUpTable)
rowsShow <- labelRcmdr(rowColFrame, textvariable=rowsValue, width=2, justify="right")
colsValue <- tclVar("2")
colsSlider <- tkscale(rowColFrame, from=2, to=10, showvalue=FALSE, variable=colsValue,
resolution=1, orient="horizontal", command=setUpTable)
colsShow <- labelRcmdr(rowColFrame, textvariable=colsValue, width=2, justify="right")
onOK <- function(){
nrows <- as.numeric(tclvalue(rowsValue))
ncols <- as.numeric(tclvalue(colsValue))
cell <- 0
counts <- rep(NA, nrows*ncols)
row.names <- rep("", nrows)
col.names <- rep("", ncols)
for (i in 1:nrows) row.names[i] <-
eval(parse(text=paste("tclvalue(", paste(".rowname.", i, sep=""),")", sep="")))
for (j in 1:ncols) col.names[j] <-
eval(parse(text=paste("tclvalue(", paste(".colname.", j, sep=""),")", sep="")))
for (i in 1:nrows){
for (j in 1:ncols){
cell <- cell+1
varname <- paste(".tab.", i, ".", j, sep="")
counts[cell] <- as.numeric(eval(parse(text=paste("tclvalue(", varname,")", sep=""))))
}
}
counts <- na.omit(counts)
if (length(counts) != nrows*ncols){
errorCondition(recall=enterTableNMBU, message=sprintf(gettextRcmdr("Number of valid entries (%d)\nnot equal to number of rows (%d) * number of columns (%d)."), length(counts), nrows, ncols))
return()
}
if (length(unique(row.names)) != nrows){
errorCondition(recall=enterTableNMBU, message=gettextRcmdr("Row names are not unique."))
return()
}
if (length(unique(col.names)) != ncols){
errorCondition(recall=enterTableNMBU, message=gettextRcmdr("Column names are not unique."))
return()
}
percents <- as.character(tclvalue(percentsVariable))
chisq <- tclvalue(chisqVariable)
chisqComp <- tclvalue(chisqComponentsVariable)
expected <- tclvalue(expFreqVariable)
fisher <- tclvalue(fisherVariable)
closeDialog()
command <- paste("matrix(c(", paste(counts, collapse=","), "), ", nrows, ", ", ncols,
", byrow=TRUE)", sep="")
# assign(".Table", justDoIt(command), envir=.GlobalEnv)
# logger(paste(".Table <- ", command, sep=""))
doItAndPrint(paste(".Table <- ", command, sep=""))
command <- paste("c(",paste(paste("'", row.names, "'", sep=""), collapse=", "), ")", sep="")
justDoIt(paste("rownames(.Table) <- ", command, sep=""))
logger(paste("rownames(.Table) <- ", command, sep=""))
command <- paste("c(",paste(paste("'", col.names, "'", sep=""), collapse=", "), ")", sep="")
justDoIt(paste("colnames(.Table) <- ", command, sep=""))
logger(paste("colnames(.Table) <- ", command, sep=""))
doItAndPrint(".Table # Counts")
if (percents == "row") doItAndPrint("rowPercents(.Table) # Row Percentages")
if (percents == "column") doItAndPrint("colPercents(.Table) # Column Percentages")
if (percents == "total") doItAndPrint("totPercents(.Table) # Percentage of Total")
if (chisq == 1) {
command <- "chisq.test(.Table, correct=FALSE)"
# logger(paste(".Test <- ", command, sep=""))
# assign(".Test", justDoIt(command), envir=.GlobalEnv)
doItAndPrint(paste(".Test <- ", command, sep=""))
if (expected == 1) doItAndPrint(".Test$expected # Expected Counts")
warnText <- NULL
if (0 < (nlt1 <- sum(.Test$expected < 1))) warnText <- paste(nlt1,
gettextRcmdr("expected frequencies are less than 1"))
if (0 < (nlt5 <- sum(.Test$expected < 5))) warnText <- paste(warnText, "\n", nlt5,
gettextRcmdr(" expected frequencies are less than 5"), sep="")
if (!is.null(warnText)) Message(message=warnText,
type="warning")
if (chisqComp == 1) {
command <- "round(.Test$residuals^2, 2) # Chi-square Components"
doItAndPrint(command)
doItAndPrint("cat('Adjusted residuals\n');round((.Table-.Test$expected)/sqrt(.Test$expected*tcrossprod((1-apply(.Table,1,sum)/sum(.Table)),(1-apply(.Table,2,sum)/sum(.Table)))),2)")
}
doItAndPrint("assocstats(.Table)")
logger("remove(.Test)")
remove(.Test, envir=.GlobalEnv)
}
if (fisher == 1) doItAndPrint("fisher.test(.Table)")
logger("remove(.Table)")
remove(.Table, envir=.GlobalEnv)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="chisq.test")
radioButtons(name="percents", buttons=c("rowPercents", "columnPercents", "totalPercents", "nonePercents"), values=c("row", "column", "total", "none"),
initialValue="none", labels=gettextRcmdr(c("Row percentages", "Column percentages", "Percentages of total", "No percentages")), title=gettextRcmdr("Compute Percentages"))
checkBoxes(frame="testsFrame", boxes=c("chisq", "chisqComponents", "expFreq", "fisher"), initialValues=c("1", "1", "1", "0"),
labels=gettextRcmdr(c("Chi-square test of independence", "Components of chi-square statistic",
"Print expected frequencies", "Fisher's exact test")))
tkgrid(labelRcmdr(rowColFrame, text=gettextRcmdr("Number of Rows:")), rowsSlider, rowsShow, sticky="w")
tkgrid(labelRcmdr(rowColFrame, text=gettextRcmdr("Number of Columns:")), colsSlider, colsShow, sticky="w")
tkgrid(rowColFrame, sticky="w")
tkgrid(labelRcmdr(top, text=gettextRcmdr("Enter counts:"), fg="blue"), sticky="w")
tkgrid(outerTableFrame, sticky="w")
tkgrid(percentsFrame, sticky="w")
tkgrid(labelRcmdr(top, text=gettextRcmdr("Hypothesis Tests"), fg="blue"), sticky="w")
tkgrid(testsFrame, sticky="w")
tkgrid(buttonsFrame, columnspan=2, sticky="w")
dialogSuffix(rows=7, columns=2)
}
#############################
## Customized two-way table
twoWayTableNMBU <- function(){
initializeDialog(title=gettextRcmdr("Two-Way Table"))
variablesFrame <- tkframe(top)
.factors <- Factors()
.numeric <- Numeric()
countBox <- variableListBox(variablesFrame, .numeric, title=gettextRcmdr("Counts (pick one)"))
rowBox <- variableListBox(variablesFrame, .factors, title=gettextRcmdr("Row variable (pick one)"))
columnBox <- variableListBox(variablesFrame, .factors, title=gettextRcmdr("Column variable (pick one)"))
onOK <- function(){
count <- getSelection(countBox)
row <- getSelection(rowBox)
column <- getSelection(columnBox)
if (length(count) == 0 || length(row) == 0 || length(column) == 0){
errorCondition(recall=twoWayTableNMBU, message=gettextRcmdr("You must select three variables."))
return()
}
if (row == column) {
errorCondition(recall=twoWayTableNMBU, message=gettextRcmdr("Row and column variables are the same."))
return()
}
percents <- as.character(tclvalue(percentsVariable))
chisq <- tclvalue(chisqTestVariable)
chisqComp <- tclvalue(chisqComponentsVariable)
expected <- tclvalue(expFreqVariable)
fisher <- tclvalue(fisherTestVariable)
closeDialog()
.activeDataSet <- ActiveDataSet()
command <- paste("table(data.frame(", row, "=rep(", .activeDataSet, "[,'", row, "'],", .activeDataSet, "[,'", count, "']),", column, "=rep(", .activeDataSet, "[,'", column, "'],", .activeDataSet, "[,'", count, "'])))", sep="")
# logger(paste(".Table <- ", command, sep=""))
# assign(".Table", justDoIt(command), envir=.GlobalEnv)
doItAndPrint(paste(".Table <- ", command, sep=""))
# logger(paste(".Table[] <- ", command, sep=""))
# assign(".Table[]", justDoIt(command), envir=.GlobalEnv)
doItAndPrint(".Table")
if (percents == "row") doItAndPrint("rowPercents(.Table) # Row Percentages")
if (percents == "column") doItAndPrint("colPercents(.Table) # Column Percentages")
if (percents == "total") doItAndPrint("totPercents(.Table) # Percentage of Total")
if (chisq == 1) {
command <- "chisq.test(.Table, correct=FALSE)"
# logger(paste(".Test <- ", command, sep=""))
# assign(".Test", justDoIt(command), envir=.GlobalEnv)
doItAndPrint(paste(".Test <- ", command, sep=""))
if (expected == 1) doItAndPrint(".Test$expected # Expected Counts")
warnText <- NULL
if (0 < (nlt1 <- sum(.Test$expected < 1))) warnText <- paste(nlt1,
gettextRcmdr("expected frequencies are less than 1"))
if (0 < (nlt5 <- sum(.Test$expected < 5))) warnText <- paste(warnText, "\n", nlt5,
gettextRcmdr(" expected frequencies are less than 5"), sep="")
if (!is.null(warnText)) Message(message=warnText,
type="warning")
if (chisqComp == 1) {
command <- "round(.Test$residuals^2, 2) # Chi-square Components"
doItAndPrint(command)
doItAndPrint("cat('Adjusted residuals\n');round((.Table-.Test$expected)/sqrt(.Test$expected*tcrossprod((1-apply(.Table,1,sum)/sum(.Table)),(1-apply(.Table,2,sum)/sum(.Table)))),2)")
}
doItAndPrint("assocstats(.Table)")
logger("remove(.Test)")
remove(.Test, envir=.GlobalEnv)
}
if (fisher == 1) doItAndPrint("fisher.test(.Table)")
logger("remove(.Table)")
remove(.Table, envir=.GlobalEnv)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="xtabs")
radioButtons(name="percents",
buttons=c("rowPercents", "columnPercents", "totalPercents", "nonePercents"),
values=c("row", "column", "total", "none"), initialValue="none",
labels=gettextRcmdr(c("Row percentages", "Column percentages", "Percentages of total", "No percentages")), title=gettextRcmdr("Compute Percentages"))
checkBoxes(frame="testsFrame", boxes=c("chisqTest", "chisqComponents", "expFreq", "fisherTest"), initialValues=c("1", "1", "1", "0"),
labels=gettextRcmdr(c("Chi-square test of independence", "Components of chi-square statistic",
"Print expected frequencies", "Fisher's exact test")))
tkgrid(getFrame(rowBox), labelRcmdr(variablesFrame, text=" "), getFrame(columnBox), labelRcmdr(variablesFrame, text=" "), getFrame(countBox), sticky="nw")
tkgrid(variablesFrame, sticky="w")
tkgrid(percentsFrame, sticky="w")
tkgrid(labelRcmdr(top, text=gettextRcmdr("Hypothesis Tests"), fg="blue"), sticky="w")
tkgrid(testsFrame, sticky="w")
tkgrid(buttonsFrame, sticky="w")
dialogSuffix(rows=6, columns=1)
}
################################
# Analysis of variance
linearModelNMBU <- function(){
defaults <- list(initial.contr="contr.sum", initial.output=c("1","0","0","0","0"), initial.subset = gettextRcmdr("<all valid cases>"))
dialog.values <- getDialog("linearModelNMBU", defaults)
initializeDialog(title=gettextRcmdr("Linear model (regression/ANOVA) - specify model"))
.activeModel <- ActiveModel()
variables <- Variables()
factors <- Factors()
# To be able to recreate settings from former models many things are defined here that have to do with randomness and such
chosen.factors <- FALSE
.factorsLabel <- tclVar("Set factors")
onFactors <- function(){
initializeDialog(subdialog,title=gettextRcmdr("Set factors"))
.variable <- Variables()
yBox <- variableListBox(subdialog, .variable, title=gettextRcmdr("Convert to factor(s) (pick zero or more)"), selectmode="multiple")
onOKsub <- function(){
chosen <- getSelection(yBox)
if (length(chosen) == 0){
assign("chosen.factors", FALSE, envir=env)
tclvalue(.factorsLabel) <- "Set factors"
tkconfigure(factorsButton, foreground="black")
if (GrabFocus()) tkgrab.release(subdialog)
tkdestroy(subdialog)
tkwm.deiconify(top)
if (GrabFocus()) tkgrab.set(top)
tkfocus(top)
tkwait.window(top)
return()
}
assign("chosen.factors", chosen, envir=env)
tclvalue(.factorsLabel) <- "Factors set"
tkconfigure(factorsButton, foreground="blue")
tkdestroy(subdialog)
tkwm.deiconify(top)
if (GrabFocus()) tkgrab.set(top)
tkfocus(top)
tkwait.window(top)
}
subOKCancelHelp()
tkgrid(getFrame(yBox), sticky="nw")
tkgrid(subButtonsFrame, columnspan=2, sticky="w")
dialogSuffix(subdialog, rows=2, columns=2, onOK=onOKsub, focus=subdialog)
}
groupsFrame <- tkframe(top)
factorsButton <- tkbutton(groupsFrame, textvariable=.factorsLabel, command=onFactors, borderwidth=3)
checkBoxes(frame="optionsFrame", boxes=c("reg","type1","type2","type3","typeR"), initialValues=dialog.values$initial.output, #c("1","0","0","0","0"),
labels=gettextRcmdr(c("Regression","ANOVA 'type I test' (sequential)", "ANOVA 'type II test' (obeying marginality)", "ANOVA 'type III test' (ignoring marginality)", "ANOVA for regression")))
onRandom <- function() {
if (GrabFocus() && .Platform$OS.type != "windows") tkgrab.release(window)
if (as.numeric(R.Version()$major) >= 2) print(help("mixlm"))
else help("mixlm")
}
helpButton <- buttonRcmdr(optionsFrame, text=gettextRcmdr("Random effects help"), width="20", command=onRandom, borderwidth=3)
tkgrid(helpButton, sticky="w")
currentModel <- if (!is.null(.activeModel))
class(get(.activeModel, envir=.GlobalEnv))[1] == "lm" || class(get(.activeModel, envir=.GlobalEnv))[1] == "mer"
else FALSE
if (currentModel) {
currentFields <- formulaFields2(get(.activeModel, envir=.GlobalEnv))
if (currentFields$data != ActiveDataSet()) currentModel <- FALSE
the.class <- class(get(.activeModel, envir=.GlobalEnv))
if(grepl("~",currentFields$lhs,fixed=TRUE)){
tmp <- strsplit(currentFields$lhs, "~", fixed=TRUE)[[1]]
currentFields$lhs <- tmp[1]; currentFields$rhs <- tmp[2]
}
}
if (isTRUE(getRcmdr("reset.model"))) {
currentModel <- FALSE
putRcmdr("reset.model", FALSE)
}
UpdateModelNumber()
modelName <- tclVar(paste("LinearModel.", getRcmdr("modelNumber"), sep=""))
modelFrame <- tkframe(top)
model <- ttkentry(modelFrame, width="20", textvariable=modelName)
onOK <- function(){
modelValue <- trim.blanks(tclvalue(modelName))
closeDialog()
if (!is.valid.name(modelValue)){
errorCondition(recall=linearModelNMBU, message=sprintf(gettextRcmdr('"%s" is not a valid name.'), modelValue), model=TRUE)
return()
}
subset <- tclvalue(subsetVariable)
putDialog ("linearModelNMBU", list (initial.contr = tclvalue(contrVariable), initial.output = c(tclvalue(regVariable),
tclvalue(type1Variable), tclvalue(type2Variable), tclvalue(type3Variable), tclvalue(typeRVariable)),
initial.subset = subset))
if (trim.blanks(subset) == gettextRcmdr("<all valid cases>") || trim.blanks(subset) == ""){
subset <- ""
putRcmdr("modelWithSubset", FALSE)
}
else{
subset <- paste(", subset=", subset, sep="")
putRcmdr("modelWithSubset", TRUE)
}
check.empty <- gsub(" ", "", tclvalue(lhsVariable))
if ("" == check.empty) {
errorCondition(recall=linearModelANOVA, message=gettextRcmdr("Left-hand side of model empty."), model=TRUE)
return()
}
check.empty <- gsub(" ", "", tclvalue(rhsVariable))
if ("" == check.empty) {
errorCondition(recall=linearModelANOVA, message=gettextRcmdr("Right-hand side of model empty."), model=TRUE)
return()
}
if (is.element(modelValue, listLinearModels())) {
if ("no" == tclvalue(checkReplace(modelValue, type=gettextRcmdr("Model")))){
UpdateModelNumber(-1)
linearModel()
return()
}
}
if(tclvalue(contrVariable) != gettextRcmdr("reml")){
if(tclvalue(contrVariable)==gettextRcmdr("contr.sum")){
command <- "options(contrasts=c('contr.sum','contr.poly'))"
} else {
command <- "options(contrasts=c('contr.treatment','contr.poly'))"
}
if(options("contrasts")$contrasts[1] != tclvalue(contrVariable))
doItAndPrint(command)
}
.activeDataSet <- ActiveDataSet()
if(!is.logical(chosen.factors)){
variables <- Variables()
command <- paste(.activeDataSet, ".tmp <- data.frame(", paste(variables[!is.element(variables,chosen.factors)], "=", ActiveDataSet(), "$", variables[!is.element(variables,chosen.factors)], ", ", sep="", collapse=""), paste(variables[is.element(variables,chosen.factors)], "=factor(", ActiveDataSet(), "$", variables[is.element(variables,chosen.factors)], "), ", sep="", collapse=""), sep="")
command <- paste(substr(command,1,nchar(command)-2),")", sep="")
doItAndPrint(command)
.activeDataSet <- paste(.activeDataSet, ".tmp", sep="")
activeDataSet(.activeDataSet)
}
type <- as.character(tclvalue(contrVariable))
formula2 <- formula1 <- paste(tclvalue(lhsVariable), tclvalue(rhsVariable), sep=" ~ ")
formula1 <- paste("lm(", formula1, sep="")
command <- paste(formula1, ", data=", .activeDataSet, subset, sep="")
if(tclvalue(contrVariable)==gettextRcmdr("reml"))
command <- paste(command, ", REML=TRUE)", sep="")
else
command <- paste(command, ")", sep="")
# logger(paste(modelValue, " <- ", command, sep=""))
# assign(modelValue, justDoIt(command), envir=.GlobalEnv)
doItAndPrint(paste(modelValue, " <- ", command, sep=""))
activeModel(modelValue)
if(tclvalue(regVariable) == gettextRcmdr("1")) doItAndPrint(paste("summary(", modelValue, ")", sep=""))
if(tclvalue(type1Variable) == gettextRcmdr("1")) doItAndPrint(paste("anova(", ActiveModel(), ")", sep=""))
if(tclvalue(type2Variable) == gettextRcmdr("1")) doItAndPrint(paste("Anova(", ActiveModel(), ', type="II")', sep=""))
if(tclvalue(type3Variable) == gettextRcmdr("1")) doItAndPrint(paste("Anova(", ActiveModel(), ', type="III")', sep=""))
if(tclvalue(typeRVariable) == gettextRcmdr("1")) doItAndPrint(paste("anova_reg(", ActiveModel(), ')', sep=""))
# if(tclvalue(mixVariable) == gettextRcmdr("1")) mixed.modelGUI()
tkfocus(CommanderWindow())
}
env <- environment()
tkgrid(labelRcmdr(groupsFrame, text=" "), factorsButton, sticky="w")
OKCancelHelp(helpSubject="linearModel", model=TRUE, reset="resetLinearModelNMBU")
tkgrid(labelRcmdr(modelFrame, text=gettextRcmdr("Enter name for model:")), model, sticky="w")
tkgrid(modelFrame, sticky="w", column=1, row=1, columnspan=2)
modelFormula3(.variables=variables, .factors=factors)
subsetBox(subset.expression = dialog.values$initial.subset)
tkgrid(getFrame(xBox), sticky="w", column=1, row=2, columnspan=1)
tkgrid(groupsFrame, sticky="w", column=2, row=2, columnspan=1)
tkgrid(outerOperatorsFrame, sticky="w", column=1, row=3, columnspan=2)
tkgrid(formulaFrame, sticky="w", column=1, row=4, columnspan=2)
radioButtons(name="contr", buttons=c("contr.sum", "contr.treatment", "reml"), values=c("contr.sum", "contr.treatment", "reml"), initialValue = dialog.values$initial.contr, #"contr.sum",
labels=gettextRcmdr(c("Sum to zero (contr.sum)", "Reference level (contr.treatment)", "REML")), title=gettextRcmdr("Parameterization"))
tkgrid(contrFrame, row=5, column=1, rowspan=1, columnspan=1, sticky="w")
tkgrid(subsetFrame, sticky="w", column=1, row=6)
tkgrid(optionsFrame, row=5, column=2, columnspan=1, rowspan=2, sticky="w")
tkgrid(buttonsFrame, sticky="w", column=1, row=7, columnspan=2)
dialogSuffix(rows=7, columns=2)
}
resetLinearModelNMBU <- function(){
putRcmdr("reset.model", TRUE)
putDialog("linearModelNMBU", NULL)
linearModelNMBU()
}
################################
# Customized GLM
generalizedLinearModelNMBU <- function(){
defaults <- list(initial.contr = "contr.treatment", initial.weights="<none>", initial.offset="<none>")
dialog.values <- getDialog("generalizedLinearModelNMBU", defaults)
families <- c("gaussian", "binomial", "poisson", "Gamma", "inverse.gaussian",
"quasibinomial", "quasipoisson")
links <- c("identity", "inverse", "log", "logit", "probit",
"cloglog", "sqrt", "1/mu^2")
availableLinks <- matrix(c(
TRUE, TRUE, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE,
FALSE, FALSE, FALSE, TRUE, TRUE, TRUE, FALSE, FALSE,
TRUE, FALSE, TRUE, FALSE, FALSE, FALSE, TRUE, FALSE,
TRUE, TRUE, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE,
TRUE, TRUE, TRUE, FALSE, FALSE, FALSE, FALSE, TRUE,
FALSE, FALSE, FALSE, TRUE, TRUE, TRUE, FALSE, FALSE,
TRUE, FALSE, TRUE, FALSE, FALSE, FALSE, TRUE, FALSE),
7, 8, byrow=TRUE)
rownames(availableLinks) <- families
colnames(availableLinks) <- links
canonicalLinks <- c("identity", "logit", "log", "inverse", "1/mu^2", "logit", "log")
names(canonicalLinks) <- families
initializeDialog(title=gettextRcmdr("Generalized Linear Model"))
.activeModel <- ActiveModel()
variables <- Variables()
factors <- Factors()
# To be able to recreate settings from former models many things are defined here that have to do with randomness and such
chosen.factors <- FALSE
.factorsLabel <- tclVar("Set factors")
onFactors <- function(){
initializeDialog(subdialog,title=gettextRcmdr("Set factors"))
.variable <- Variables()
yBox <- variableListBox(subdialog, .variable, title=gettextRcmdr("Convert to factor(s) (pick zero or more)"), selectmode="multiple")
onOKsub <- function(){
chosen <- getSelection(yBox)
if (length(chosen) == 0){
assign("chosen.factors", FALSE, envir=env)
tclvalue(.factorsLabel) <- "Set factors"
tkconfigure(factorsButton, foreground="black")
if (GrabFocus()) tkgrab.release(subdialog)
tkdestroy(subdialog)
tkwm.deiconify(top)
if (GrabFocus()) tkgrab.set(top)
tkfocus(top)
tkwait.window(top)
return()
}
assign("chosen.factors", chosen, envir=env)
tclvalue(.factorsLabel) <- "Factors set"
tkconfigure(factorsButton, foreground="blue")
tkdestroy(subdialog)
tkwm.deiconify(top)
if (GrabFocus()) tkgrab.set(top)
tkfocus(top)
tkwait.window(top)
}
subOKCancelHelp()
tkgrid(getFrame(yBox), sticky="nw")
tkgrid(subButtonsFrame, columnspan=2, sticky="w")
dialogSuffix(subdialog, rows=2, columns=2, onOK=onOKsub, focus=subdialog)
}
groupsFrame <- tkframe(top)
factorsButton <- tkbutton(groupsFrame, textvariable=.factorsLabel, command=onFactors, borderwidth=3)
currentModel <- if (!is.null(.activeModel))
class(get(.activeModel, envir=.GlobalEnv))[1] == "glm"
else FALSE
if (currentModel) {
currentFields <- formulaFields(get(.activeModel, envir=.GlobalEnv), glm=TRUE)
if (currentFields$data != ActiveDataSet()) currentModel <- FALSE
}
if (isTRUE(getRcmdr("reset.model"))) {
currentModel <- FALSE
putRcmdr("reset.model", FALSE)
}
modelFormula3(.variables=variables, .factors=factors)
UpdateModelNumber()
modelName <- tclVar(paste("GLM.", getRcmdr("modelNumber"), sep=""))
modelFrame <- tkframe(top)
model <- ttkentry(modelFrame, width="20", textvariable=modelName)
linkFamilyFrame <- tkframe(top)
familyFrame <- tkframe(linkFamilyFrame)
familyBox <- tklistbox(familyFrame, height="4", exportselection="FALSE",
selectmode="single", background="white")
familyScroll <- ttkscrollbar(familyFrame,
command=function(...) tkyview(familyBox, ...))
tkconfigure(familyBox, yscrollcommand=function(...) tkset(familyScroll, ...))
for (fam in families) tkinsert(familyBox, "end", fam)
linkFrame <- tkframe(linkFamilyFrame)
linkBox <- tklistbox(linkFrame, height="4", exportselection="FALSE",
selectmode="single", background="white")
weightsName <- tclVar(gettextRcmdr(dialog.values$initial.weights))
weightsFrame <- tkframe(top)
weights <- ttkentry(weightsFrame, width="20", textvariable=weightsName)
offsetName <- tclVar(gettextRcmdr(dialog.values$initial.offset))
offsetFrame <- tkframe(top)
offset <- ttkentry(offsetFrame, width="20", textvariable=offsetName)
subsetBox(model=TRUE)
onFamilySelect <- function(){
family <- families[as.numeric(tkcurselection(familyBox)) + 1]
availLinks <- links[availableLinks[family,]]
tkdelete(linkBox, "0", "end")
for (lnk in availLinks) tkinsert(linkBox, "end", lnk)
canLink <- canonicalLinks[family]
tkconfigure(linkBox, height=length(availLinks))
tkselection.set(linkBox, which(canLink == availLinks) - 1)
}
onOK <- function(){
check.empty <- gsub(" ", "", tclvalue(lhsVariable))
if ("" == check.empty) {
errorCondition(recall=generalizedLinearModelNMBU, model=TRUE, message=gettextRcmdr("Left-hand side of model empty."))
return()
}
check.empty <- gsub(" ", "", tclvalue(rhsVariable))
if ("" == check.empty) {
errorCondition(recall=generalizedLinearModelNMBU, model=TRUE, message=gettextRcmdr("Right-hand side of model empty."))
return()
}
modelValue <- trim.blanks(tclvalue(modelName))
if (!is.valid.name(modelValue)){
errorCondition(recall=generalizedLinearModelNMBU, model=TRUE, message=sprintf(gettextRcmdr('"%s" is not a valid name.'), modelValue))
return()
}
if (is.element(modelValue, listGeneralizedLinearModels())) {
if ("no" == tclvalue(checkReplace(modelValue, type=gettextRcmdr("Model")))){
UpdateModelNumber(-1)
closeDialog()
generalizedLinearModelNMBU()
return()
}
}
if(tclvalue(contrVariable)==gettextRcmdr("contr.sum")){
command <- "options(contrasts=c('contr.sum','contr.poly'))"
} else {
command <- "options(contrasts=c('contr.treatment','contr.poly'))"
}
if(options("contrasts")$contrasts[1] != tclvalue(contrVariable))
doItAndPrint(command)
if(!is.logical(chosen.factors)){
variables <- Variables()
command <- paste(.activeDataSet, ".tmp <- data.frame(", paste(variables[!is.element(variables,chosen.factors)], "=", ActiveDataSet(), "$", variables[!is.element(variables,chosen.factors)], ", ", sep="", collapse=""), paste(variables[is.element(variables,chosen.factors)], "=factor(", ActiveDataSet(), "$", variables[is.element(variables,chosen.factors)], "), ", sep="", collapse=""), sep="")
command <- paste(substr(command,1,nchar(command)-2),")", sep="")
doItAndPrint(command)
.activeDataSet <- paste(.activeDataSet, ".tmp", sep="")
activeDataSet(.activeDataSet)
}
formula <- paste(tclvalue(lhsVariable), tclvalue(rhsVariable), sep=" ~ ")
family <- families[as.numeric(tkcurselection(familyBox)) + 1]
availLinks <- links[availableLinks[family,]]
link <- availLinks[as.numeric(tkcurselection(linkBox)) + 1]
subset <- tclvalue(subsetVariable)
weightsValue <- tclvalue(weightsName)
offsetValue <- tclvalue(offsetName)
putDialog ("generalizedLinearModelNMBU", list (initial.contr = tclvalue(contrVariable), initial.offset = offsetValue,
initial.weights = weightsValue))
closeDialog()
if (trim.blanks(subset) == gettextRcmdr("<all valid cases>") || trim.blanks(subset) == ""){
subset <- ""
putRcmdr("modelWithSubset", FALSE)
}
else{
subset <- paste(", subset=", subset, sep="")
putRcmdr("modelWithSubset", TRUE)
}
command <- paste("glm(", formula, ifelse(offsetValue=="<none>","",paste(" + offset(",offsetValue,")",sep="")), ", family=", family, "(", link,
"),", ifelse(weightsValue=="<none>","",paste(" weights=",weightsValue,"," ,sep="")), " data=", ActiveDataSet(), subset, ")", sep="")
# logger(paste(modelValue, " <- ", command, sep=""))
# assign(modelValue, justDoIt(command), envir=.GlobalEnv)
doItAndPrint(paste(modelValue, " <- ", command, sep=""))
doItAndPrint(paste("summary(", modelValue, ")", sep=""))
activeModel(modelValue)
model.class <- eval(parse(text=paste("class(",modelValue,")",sep="")))
if(model.class[1]=="glmerMod"){
doItAndPrint(paste("Anova(", modelValue, ",test='Chisq',type=3)", sep=""))
} else {
doItAndPrint(paste("Anova(", modelValue, ",test='LR',type=3)", sep=""))
}
doItAndPrint(paste("logLik(", modelValue, ")",sep=""))
tkfocus(CommanderWindow())
}
env <- environment()
tkgrid(labelRcmdr(groupsFrame, text=" "), factorsButton, sticky="w")
OKCancelHelp(helpSubject="generalizedLinearModel", model=TRUE, reset="resetGLMNMBU")
helpButton <- buttonRcmdr(buttonsFrame, text="Help", width="12", command=onHelp)
tkgrid(labelRcmdr(modelFrame, text=gettextRcmdr("Enter name for model:")), model, sticky="w")
tkgrid(modelFrame, sticky="w", row=1, column=1, columnspan=2)
tkgrid(getFrame(xBox), sticky="w", row=2, column=1, columnspan=1)
tkgrid(groupsFrame, sticky="w", column=2, row=2, columnspan=1)
tkgrid(outerOperatorsFrame, sticky="w", row=3, column=1, columnspan=2)
tkgrid(formulaFrame, sticky="w", row=4, column=1, columnspan=2)
radioButtons(name="contr", buttons=c("contr.sum", "contr.treatment"), values=c("contr.sum", "contr.treatment"), initialValue = dialog.values$initial.contr, #"contr.sum",
labels=gettextRcmdr(c("Sum to zero (contr.sum)", "Reference level (contr.treatment)")), title=gettextRcmdr("Parameterization"))
tkgrid(contrFrame, row=5, column=1, rowspan=1, columnspan=1, sticky="w")
spaceFrame <- tkframe(top)
tkgrid(labelRcmdr(spaceFrame, text=gettextRcmdr(" ")), sticky="w")
tkgrid(spaceFrame, sticky="w", row=6, column=1, columnspan=2)
tkgrid(labelRcmdr(weightsFrame, text=gettextRcmdr("Weights (optional):")), weights, sticky="w")
tkgrid(weightsFrame, sticky="w", row=7, column=1, columnspan=1)
tkgrid(labelRcmdr(offsetFrame, text=gettextRcmdr(" Offset (optional):")), offset, sticky="w")
tkgrid(offsetFrame, sticky="w", row=7, column=2, columnspan=1)
tkgrid(subsetFrame, sticky="w", row=8, column=1, columnspan=2)
tkgrid(labelRcmdr(linkFamilyFrame, text=gettextRcmdr("Family (double-click to select)"), fg="blue"),
labelRcmdr(linkFamilyFrame, text=" "), labelRcmdr(linkFamilyFrame, text=gettextRcmdr("Link function"), fg="blue"), sticky="w")
tkgrid(familyBox, familyScroll, sticky="nw")
tkgrid(linkBox, sticky="nw")
tkgrid(familyFrame, labelRcmdr(linkFamilyFrame, text=" "), linkFrame, sticky="nw")
tkgrid(linkFamilyFrame, sticky="w", row=9, column=1, columnspan=2)
tkgrid(buttonsFrame, sticky="w", row=10, column=1, columnspan=2)
tkgrid.configure(familyScroll, sticky="ns")
fam <- if (currentModel) which(currentFields$family == families) - 1
else 1
tkselection.set(familyBox, fam)
availLinks <- links[availableLinks[fam + 1,]]
for (lnk in availLinks) tkinsert(linkBox, "end", lnk)
tkconfigure(linkBox, height=length(availLinks))
lnk <- if (currentModel) which(currentFields$link == availLinks) - 1
else 0
tkselection.set(linkBox, lnk)
tkbind(familyBox, "<Double-ButtonPress-1>", onFamilySelect)
dialogSuffix(rows=10, columns=2, focus=lhsEntry, preventDoubleClick=TRUE)
}
resetGLMNMBU <- function(){
putRcmdr("reset.model", TRUE)
putDialog("generalizedLinearModelNMBU", NULL)
generalizedLinearModelNMBU()
}
################################
# Customized multiLogit
multinomialLogitModelNMBU <- function(){
initializeDialog(title=gettextRcmdr("Multinomial Logit Model"))
.activeModel <- ActiveModel()
.activeDataSet <- ActiveDataSet()
currentModel <- if (!is.null(.activeModel))
class(get(.activeModel, envir=.GlobalEnv))[1] == "multinom"
# eval(parse(text=paste("class(", .activeModel, ")[1] == 'multinom'", sep="")),
# envir=.GlobalEnv)
else FALSE
if (currentModel) {
currentFields <- formulaFields(get(.activeModel, envir=.GlobalEnv))
# currentFields <- formulaFields(eval(parse(text=.activeModel),
# envir=.GlobalEnv))
if (currentFields$data != .activeDataSet) currentModel <- FALSE
}
UpdateModelNumber()
modelName <- tclVar(paste("MLM.", getRcmdr("modelNumber"), sep=""))
modelFrame <- tkframe(top)
model <- ttkentry(modelFrame, width="20", textvariable=modelName)
baseLevel <- tclVar("")
baseFrame <- tkframe(top)
baseV <- ttkentry(baseFrame, width="20", textvariable=baseLevel)
weightsName <- tclVar(gettextRcmdr("<none>"))
weightsFrame <- tkframe(top)
weights <- ttkentry(weightsFrame, width="20", textvariable=weightsName)
onOK <- function(){
modelValue <- trim.blanks(tclvalue(modelName))
baseValue <- trim.blanks(tclvalue(baseLevel))
weightsValue <- tclvalue(weightsName)
closeDialog()
if (!is.valid.name(modelValue)){
errorCondition(recall=multinomialLogitModelNMBU, message=sprintf(gettextRcmdr('"%s" is not a valid name.'), modelValue), model=TRUE)
return()
}
subset <- tclvalue(subsetVariable)
if (trim.blanks(subset) == gettextRcmdr("<all valid cases>") || trim.blanks(subset) == ""){
subset <- ""
putRcmdr("modelWithSubset", FALSE)
}
else{
subset <- paste(", subset=", subset, sep="")
putRcmdr("modelWithSubset", TRUE)
}
check.empty <- gsub(" ", "", tclvalue(lhsVariable))
if ("" == check.empty) {
errorCondition(recall=multinomialLogitModelNMBU, message=gettextRcmdr("Left-hand side of model empty."), model=TRUE)
return()
}
check.empty <- gsub(" ", "", tclvalue(rhsVariable))
if ("" == check.empty) {
errorCondition(recall=multinomialLogitModelNMBU, message=gettextRcmdr("Right-hand side of model empty."), model=TRUE)
return()
}
if (!is.factor(eval(parse(text=tclvalue(lhsVariable)), envir=get(.activeDataSet, envir=.GlobalEnv)))){
# if (!is.factor(eval(parse(text=tclvalue(lhsVariable)), envir=eval(parse(text=.activeDataSet), envir=.GlobalEnv)))){
errorCondition(recall=multinomialLogitModelNMBU, message=gettextRcmdr("Response variable must be a factor"))
return()
}
if (baseValue!="" && !is.element(baseValue, justDoIt(paste("levels(", ActiveDataSet(), "$", tclvalue(lhsVariable), ")", sep="")))){
errorCondition(recall=multinomialLogitModelNMBU, message=gettextRcmdr("'Base level' must be a level used in the response."))
return()
}
if (is.element(modelValue, listMultinomialLogitModels())) {
if ("no" == tclvalue(checkReplace(modelValue, type=gettextRcmdr("Model")))){
UpdateModelNumber(-1)
multinomialLogitModelNMBU()
return()
}
}
if(baseValue != ""){
command <- paste("levels(", .activeDataSet, "$", tclvalue(lhsVariable), ")", sep="")
effLevsO <- justDoIt(command)
effLevs <- c(baseValue, effLevsO[!is.element(effLevsO,baseValue)])
command <- paste(.activeDataSet, "$", tclvalue(lhsVariable), " <- factor(", .activeDataSet, "$", tclvalue(lhsVariable), ", levels=c('", paste(effLevs,sep="", collapse="', '"), "'))", sep="")
doItAndPrint(command)
}
formula <- paste(tclvalue(lhsVariable), tclvalue(rhsVariable), sep=" ~ ")
command <- paste("multinom(", formula,
",", ifelse(weightsValue=="<none>","",paste(" weights=",weightsValue,"," ,sep="")), " data=", .activeDataSet, subset, ", trace=FALSE)", sep="")
# logger(paste(modelValue, " <- ", command, sep=""))
# assign(modelValue, justDoIt(command), envir=.GlobalEnv)
doItAndPrint(paste(modelValue, " <- ", command, sep=""))
doItAndPrint(paste("summaryMultinom(", modelValue, ")", sep=""))
activeModel(modelValue)
if(baseValue != ""){
command <- paste(.activeDataSet, "$", tclvalue(lhsVariable), " <- factor(", .activeDataSet, "$", tclvalue(lhsVariable), ", levels=c('", paste(effLevsO,sep="", collapse="', '"), "'))", sep="")
doItAndPrint(command)
}
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="multinom", model=TRUE)
tkgrid(labelRcmdr(modelFrame, text=gettextRcmdr("Enter name for model:")), model, sticky="w")
tkgrid(modelFrame, sticky="w", row=1, column=1, columnspan=2)
modelFormula()
subsetBox(model=TRUE)
tkgrid(getFrame(xBox), sticky="w", row=2, column=1, columnspan=2)
tkgrid(outerOperatorsFrame, sticky="w", row=3, column=1, columnspan=2)
tkgrid(formulaFrame, sticky="w", row=4, column=1, columnspan=2)
tkgrid(subsetFrame, sticky="w", row=5, column=1, columnspan=2)
tkgrid(labelRcmdr(baseFrame, text=gettextRcmdr("Base level (optional):")), baseV, sticky="w")
tkgrid(baseFrame, sticky="w", row=6, column=1, columnspan=1)
tkgrid(labelRcmdr(weightsFrame, text=gettextRcmdr(" Weights (optional):")), weights, sticky="w")
tkgrid(weightsFrame, sticky="w", row=6, column=2, columnspan=1)
tkgrid(buttonsFrame, sticky="w", row=7, column=1, columnspan=2)
dialogSuffix(rows=7, columns=2, focus=lhsEntry, preventDoubleClick=TRUE)
}
################################
# Customized ordinalRegression
ordinalRegressionModelNMBU <- function(){
initializeDialog(title=gettextRcmdr("Ordinal Regression Model"))
.activeModel <- ActiveModel()
.activeDataSet <- ActiveDataSet()
currentModel <- if (!is.null(.activeModel))
class(get(.activeModel, envir=.GlobalEnv))[1] == "polr"
# eval(parse(text=paste("class(", .activeModel, ")[1] == 'polr'", sep="")),
# envir=.GlobalEnv)
else FALSE
if (currentModel) {
currentFields <- formulaFields(get(.activeModel, envir=.GlobalEnv))
# currentFields <- formulaFields(eval(parse(text=.activeModel),
# envir=.GlobalEnv))
if (currentFields$data != .activeDataSet) currentModel <- FALSE
}
UpdateModelNumber()
modelName <- tclVar(paste("OrdRegModel.", getRcmdr("modelNumber"), sep=""))
modelFrame <- tkframe(top)
model <- ttkentry(modelFrame, width="20", textvariable=modelName)
radioButtons(name="modelType",
buttons=c("logistic", "probit", "cloglog"),
labels=gettextRcmdr(c("Proportional-odds logit", "Ordered probit", "Complementary log-log")),
title=gettextRcmdr("Type of Model"))
weightsName <- tclVar(gettextRcmdr("<none>"))
weightsFrame <- tkframe(top)
weights <- ttkentry(weightsFrame, width="20", textvariable=weightsName)
onOK <- function(){
modelValue <- trim.blanks(tclvalue(modelName))
weightsValue <- tclvalue(weightsName)
closeDialog()
if (!is.valid.name(modelValue)){
errorCondition(recall=ordinalRegressionModelNMBU, message=sprintf(gettextRcmdr('"%s" is not a valid name.'), modelValue), model=TRUE)
return()
}
subset <- tclvalue(subsetVariable)
if (trim.blanks(subset) == gettextRcmdr("<all valid cases>") || trim.blanks(subset) == ""){
subset <- ""
putRcmdr("modelWithSubset", FALSE)
}
else{
subset <- paste(", subset=", subset, sep="")
putRcmdr("modelWithSubset", TRUE)
}
check.empty <- gsub(" ", "", tclvalue(lhsVariable))
if ("" == check.empty) {
errorCondition(recall=ordinalRegressionModelNMBU, message=gettextRcmdr("Left-hand side of model empty."), model=TRUE)
return()
}
check.empty <- gsub(" ", "", tclvalue(rhsVariable))
if ("" == check.empty) {
errorCondition(recall=ordinalRegressionModelNMBU, message=gettextRcmdr("Right-hand side of model empty."), model=TRUE)
return()
}
if (!is.factor(eval(parse(text=tclvalue(lhsVariable)), envir=get(.activeDataSet, envir=.GlobalEnv)))){
# if (!is.factor(eval(parse(text=tclvalue(lhsVariable)), envir=eval(parse(text=.activeDataSet), envir=.GlobalEnv)))){
errorCondition(recall=ordinalRegressionModelNMBU, message=gettextRcmdr("Response variable must be a factor"))
return()
}
if (is.element(modelValue, listProportionalOddsModels())) {
if ("no" == tclvalue(checkReplace(modelValue, type=gettextRcmdr("Model")))){
UpdateModelNumber(-1)
ordinalRegressionModelNMBU()
return()
}
}
formula <- paste(tclvalue(lhsVariable), tclvalue(rhsVariable), sep=" ~ ")
command <- paste("polr(", formula, ', method="', tclvalue(modelTypeVariable),
'",', ifelse(weightsValue=='<none>','',paste(' weights=',weightsValue,',' ,sep='')), ' data=', .activeDataSet, subset, ", Hess=TRUE)", sep="")
# logger(paste(modelValue, " <- ", command, sep=""))
# assign(modelValue, justDoIt(command), envir=.GlobalEnv)
doItAndPrint(paste(modelValue, " <- ", command, sep=""))
doItAndPrint(paste("summaryOrdinal(", modelValue, ")", sep=""))
activeModel(modelValue)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="polr", model=TRUE)
tkgrid(labelRcmdr(modelFrame, text=gettextRcmdr("Enter name for model:")), model, sticky="w")
tkgrid(modelFrame, sticky="w", row=1, column=1, columnspan=2)
modelFormula()
subsetBox(model=TRUE)
tkgrid(getFrame(xBox), sticky="w", row=2, column=1, columnspan=2)
tkgrid(outerOperatorsFrame, sticky="w", row=3, column=1, columnspan=2)
tkgrid(formulaFrame, sticky="w", row=4, column=1, columnspan=2)
tkgrid(subsetFrame, sticky="w", row=5, column=1, columnspan=2)
tkgrid(modelTypeFrame, sticky="w", row=6, column=1, columnspan=1)
tkgrid(labelRcmdr(weightsFrame, text=gettextRcmdr(" Weights (optional):")), weights, sticky="w")
tkgrid(weightsFrame, sticky="w", row=6, column=2, columnspan=1)
tkgrid(buttonsFrame, sticky="w", row=7, column=1, columnspan=2)
dialogSuffix(rows=7, columns=2, focus=lhsEntry, preventDoubleClick=TRUE)
}
################################
# Customized numerical summaries
numericalSummariesNMBU <- function(){
defaults <- list(initial.x=NULL, initial.mean="1", initial.median="0", initial.sum="0", initial.sumSq="0", initial.sd="1", initial.sdErr="0", initial.var="0", initial.cv="0",
initial.quantiles.variable="1",
initial.quantiles="0, .25, .5, .75, 1",
initial.skewness="0", initial.kurtosis="0", initial.type="2",
initial.group=NULL)
dialog.values <- getDialog("numericalSummariesNMBU", defaults)
initial.group <- dialog.values$initial.group
initializeDialog(title=gettextRcmdr("Numerical Summaries"))
xBox <- variableListBox(top, Numeric(), selectmode="multiple", title=gettextRcmdr("Variables (pick one or more)"),
initialSelection=varPosn(dialog.values$initial.x, "numeric"))
selectFrame <- tkframe(top)
checkBoxes(frame="checkBoxFrame", boxes=c("mean", "median", "sum", "sumSq", "sd", "sdErr", "var", "cv"),
initialValues=c(dialog.values$initial.mean, dialog.values$initial.median, dialog.values$initial.sum, dialog.values$initial.sumSq, dialog.values$initial.sd, dialog.values$initial.sdErr, dialog.values$initial.var, dialog.values$initial.cv), #c(1,0,0,0,0,0,0,0),
labels=gettextRcmdr(c("Mean", "Median", "Sum", "Sum of suqares", "Standard Deviation", "Standard Error of the Mean", "Variance", "Coefficient of Variation")))
checkBoxes(window=selectFrame, frame="skCheckBoxFrame", boxes=c("skewness", "kurtosis"),
initialValues=c(dialog.values$initial.skewness, dialog.values$initial.kurtosis),
labels=gettextRcmdr(c("Skewness", "Kurtosis")))
radioButtons(window=selectFrame, name="typeButtons", buttons=c("b1", "b2", "b3"), values=c("1", "2", "3"),
initialValue=dialog.values$initial.type,
labels=gettextRcmdr(c("Type 1", "Type 2", "Type 3")))
quantilesVariable <- tclVar(dialog.values$initial.quantiles.variable)
quantilesFrame <- tkframe(top)
quantilesCheckBox <- tkcheckbutton(quantilesFrame, variable=quantilesVariable)
quantiles <- tclVar(dialog.values$initial.quantiles)
quantilesEntry <- ttkentry(quantilesFrame, width="20", textvariable=quantiles)
groupsBox(recall=numericalSummariesNMBU, label=gettextRcmdr("Summarize by:"),
initialLabel=gettextRcmdr("Summarize by groups"),
initialGroup=initial.group)
onOK <- function(){
x <- getSelection(xBox)
quants <- tclvalue(quantiles)
meanVar <- tclvalue(meanVariable)
medianVar <- tclvalue(medianVariable)
sumVar <- tclvalue(sumVariable)
sumSqVar <- tclvalue(sumSqVariable)
sdVar <- tclvalue(sdVariable)
sdErrVar <- tclvalue(sdErrVariable)
varVar <- tclvalue(varVariable)
cvVar <- tclvalue(cvVariable)
quantsVar <- tclvalue(quantilesVariable)
skewnessVar <- tclvalue(skewnessVariable)
kurtosisVar <- tclvalue(kurtosisVariable)
typeVar <- tclvalue(typeButtonsVariable)
putDialog("numericalSummariesNMBU", list(
initial.x=x, initial.mean=meanVar, initial.median=medianVar, initial.sum=sumVar, initial.sumSq=sumSqVar, initial.sd=sdVar, initial.sdErr=sdErrVar, initial.var=sdVar, initial.cv=cvVar,
initial.quantiles.variable=quantsVar, initial.quantiles=quants,
initial.skewness=skewnessVar, initial.kurtosis=kurtosisVar, initial.type=typeVar,
initial.group=if (.groups != FALSE) .groups else NULL
))
if (length(x) == 0){
errorCondition(recall=numericalSummariesNMBU, message=gettextRcmdr("You must select a variable."))
return()
}
closeDialog()
quants <- paste("c(", gsub(",+", ",", gsub(" ", ",", quants)), ")", sep="")
.activeDataSet <- ActiveDataSet()
vars <- if (length(x) == 1) paste('"', x, '"', sep="")
else paste("c(", paste('"', x, '"', collapse=", ", sep=""), ")", sep="")
vars <- paste(.activeDataSet, "[,", vars, "]", sep="")
stats <- paste("c(",
paste(c('"mean"', '"median"', '"sum"', '"sumSq"', '"sd"', '"sdErr"', '"var"', '"quantiles"', '"cv"', '"skewness"', '"kurtosis"')
[c(meanVar, medianVar, sumVar, sumSqVar, sdVar, sdErrVar, varVar, quantsVar, cvVar, skewnessVar, kurtosisVar) == 1],
collapse=", "), ")", sep="")
if (stats == "c()"){
errorCondition(recall=numericalSummariesNMBU, message=gettextRcmdr("No statistics selected."))
return()
}
type.text <- if (skewnessVar == 1 || kurtosisVar == 1 || quantsVar == 1) paste(', type="', typeVar, '"', sep="") else ""
command <- if (.groups != FALSE) {
grps <- paste(.activeDataSet, "$", .groups, sep="")
paste("numSummaryNMBU(", vars, ", groups=", grps, ", statistics=", stats,
", quantiles=", quants, type.text, ")", sep="")
}
else paste("numSummaryNMBU(", vars, ", statistics=", stats,
", quantiles=", quants, type.text, ")", sep="")
doItAndPrint(command)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="numSummary", reset="numericalSummariesNMBU")
tkgrid(getFrame(xBox), sticky="nw")
tkgrid(checkBoxFrame, sticky="w")
tkgrid(skCheckBoxFrame, typeButtonsFrame, sticky="nw")
tkgrid(selectFrame, sticky="w")
tkgrid(labelRcmdr(quantilesFrame, text=gettextRcmdr("Quantiles")), quantilesCheckBox,
labelRcmdr(quantilesFrame, text=gettextRcmdr(" quantiles:")), quantilesEntry, sticky="w")
tkgrid(quantilesFrame, sticky="w")
tkgrid(groupsFrame, sticky="w")
tkgrid(buttonsFrame, sticky="w")
dialogSuffix(rows=7, columns=1)
}
#####################################
# Bugfixed one-way ANOVA
oneWayAnovaNMBU <- function(){
initializeDialog(title=gettextRcmdr("One-Way Analysis of Variance"))
UpdateModelNumber()
modelName <- tclVar(paste("AnovaModel.", getRcmdr("modelNumber"), sep=""))
modelFrame <- tkframe(top)
model <- ttkentry(modelFrame, width="20", textvariable=modelName)
groupBox <- variableListBox(top, Factors(), title=gettextRcmdr("Groups (pick one)"))
responseBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Response Variable (pick one)"))
optionsFrame <- tkframe(top)
pairwiseVariable <- tclVar("0")
pairwiseCheckBox <- tkcheckbutton(optionsFrame, variable=pairwiseVariable)
onOK <- function(){
modelValue <- trim.blanks(tclvalue(modelName))
if (!is.valid.name(modelValue)){
UpdateModelNumber(-1)
errorCondition(recall=oneWayAnova, message=sprintf(gettextRcmdr('"%s" is not a valid name.'), modelValue))
return()
}
if (is.element(modelValue, listAOVModels())) {
if ("no" == tclvalue(checkReplace(modelValue, type=gettextRcmdr("Model")))){
UpdateModelNumber(-1)
tkdestroy(top)
oneWayAnova()
return()
}
}
putRcmdr("modelWithSubset", FALSE)
group <- getSelection(groupBox)
response <- getSelection(responseBox)
closeDialog()
if (length(group) == 0){
errorCondition(recall=oneWayAnova, message=gettextRcmdr("You must select a groups factor."))
return()
}
if (length(response) == 0){
errorCondition(recall=oneWayAnova, message=gettextRcmdr("You must select a response variable."))
return()
}
.activeDataSet <- ActiveDataSet()
command <- paste(modelValue, " <- aov(", response, " ~ ", group, ", data=", .activeDataSet, ")", sep="")
justDoIt(command)
logger(command)
doItAndPrint(paste("summary(", modelValue, ")", sep=""))
doItAndPrint(paste("numSummary(", .activeDataSet, "$", response, " , groups=", .activeDataSet, "$", group,
', statistics=c("mean", "sd"))', sep=""))
activeModel(modelValue)
pairwise <- tclvalue(pairwiseVariable)
if (pairwise == 1) {
if (eval(parse(text=paste("length(levels(", .activeDataSet, "$", group, ")) < 3"))))
Message(message=gettextRcmdr("Factor has fewer than 3 levels; pairwise comparisons omitted."),
type="warning")
# the following lines modified by Richard Heiberger and subsequently by J. Fox
else {
command <- paste(".Pairs <- glht(", modelValue, ", linfct = mcp(", group, ' = "Tukey"))', sep="")
justDoIt(command)
logger(command)
doItAndPrint("summary(.Pairs) # pairwise tests")
doItAndPrint("confint(.Pairs) # confidence intervals")
doItAndPrint("cld(.Pairs) # compact letter display")
justDoIt("old.oma <- par(oma=c(0,5,0,0))")
logger("old.oma <- par(oma=c(0,5,0,0))")
justDoIt("plot(confint(.Pairs))")
logger("plot(confint(.Pairs))")
justDoIt("par(old.oma)")
logger("par(old.oma)")
logger("remove(.Pairs)")
remove(.Pairs, envir=.GlobalEnv)
}
}
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="anova", model=TRUE)
tkgrid(labelRcmdr(modelFrame, text=gettextRcmdr("Enter name for model: ")), model, sticky="w")
tkgrid(modelFrame, sticky="w", columnspan=2)
tkgrid(getFrame(groupBox), getFrame(responseBox), sticky="nw")
tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Pairwise comparisons of means")), pairwiseCheckBox, sticky="w")
tkgrid(optionsFrame, sticky="w", columnspan=2)
tkgrid(buttonsFrame, columnspan=2, sticky="w")
dialogSuffix(rows=4, columns=2)
}
#####################################
# Bugfixed multi-way ANOVA
multiWayAnovaNMBU <- function(){
initializeDialog(title=gettextRcmdr("Multi-Way Analysis of Variance"))
UpdateModelNumber()
modelName <- tclVar(paste("AnovaModel.", getRcmdr("modelNumber"), sep=""))
modelFrame <- tkframe(top)
model <- ttkentry(modelFrame, width="20", textvariable=modelName)
groupBox <- variableListBox(top, Factors(), selectmode="multiple", title=gettextRcmdr("Factors (pick one or more)"))
responseBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Response Variable (pick one)"))
onOK <- function(){
modelValue <- trim.blanks(tclvalue(modelName))
if (!is.valid.name(modelValue)){
UpdateModelNumber(-1)
errorCondition(recall=multiWayAnova, message=sprintf(gettextRcmdr('"%s" is not a valid name.'), modelValue))
return()
}
if (is.element(modelValue, listAOVModels())) {
if ("no" == tclvalue(checkReplace(modelValue, type=gettextRcmdr("Model")))){
UpdateModelNumber(-1)
tkdestroy(top)
multiWayAnova()
return()
}
}
putRcmdr("modelWithSubset", FALSE)
groups <- getSelection(groupBox)
response <- getSelection(responseBox)
closeDialog()
if (length(groups) == 0){
errorCondition(recall=multiWayAnova, message=gettextRcmdr("You must select at least one factor."))
return()
}
if (length(response) == 0){
errorCondition(recall=multiWayAnova, message=gettextRcmdr("You must select a response variable."))
return()
}
.activeDataSet <- ActiveDataSet()
groups.list <- paste(paste(groups, "=", .activeDataSet, "$", groups, sep=""), collapse=", ")
doItAndPrint(paste(modelValue, " <- (lm(", response, " ~ ", paste(groups, collapse="*"),
", data=", .activeDataSet, "))", sep=""))
doItAndPrint(paste("Anova(", modelValue, ")", sep=""))
doItAndPrint(paste("tapply(", .activeDataSet, "$", response, ", list(", groups.list,
"), mean, na.rm=TRUE) # means", sep=""))
doItAndPrint(paste("tapply(", .activeDataSet, "$", response, ", list(", groups.list,
"), sd, na.rm=TRUE) # std. deviations", sep=""))
doItAndPrint(paste("tapply(", .activeDataSet, "$", response, ", list(", groups.list,
"), function(x) sum(!is.na(x))) # counts", sep=""))
activeModel(modelValue)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="Anova", model=TRUE)
tkgrid(labelRcmdr(modelFrame, text=gettextRcmdr("Enter name for model: ")), model, sticky="w")
tkgrid(modelFrame, sticky="w", columnspan=2)
tkgrid(getFrame(groupBox), getFrame(responseBox), sticky="nw")
tkgrid(buttonsFrame, columnspan=2, sticky="w")
dialogSuffix(rows=4, columns=2)
}
#################################
# Two sample t-test (summarized data)
twoSamplesTTestSum <- function(){
initializeDialog(title=gettextRcmdr("Two samples t-test"))
onOK <- function(){ # Actions to perform
mu1 <- as.character(tclvalue(mu1Level))
n1 <- as.character(tclvalue(n1Level))
sd1 <- as.character(tclvalue(sd1Level))
mu2 <- as.character(tclvalue(mu2Level))
n2 <- as.character(tclvalue(n2Level))
sd2 <- as.character(tclvalue(sd2Level))
mu0 <- as.character(tclvalue(mu0Level))
alternative <- as.character(tclvalue(alternativeVariable))
level <- tclvalue(confidenceLevel)
variances <- as.character(tclvalue(variancesVariable))
closeDialog()
doItAndPrint(paste("t_test_sum(means=c(", mu1,",",mu2, "), sds=c(", sd1,",",sd2, "), ns=c(", n1,",",n2, "), alternative='",
alternative, "', mu=", mu0, ", var.equal=", variances, ", conf.level=", level, ")", sep=""))
tkfocus(CommanderWindow())
}
# Set up GUI
OKCancelHelp(helpSubject="t_test")
grFrame <- tkframe(top);
tkgrid(labelRcmdr(grFrame, text=gettextRcmdr(""), fg="blue"),sticky="w")
tkgrid(labelRcmdr(grFrame, text=gettextRcmdr("Group 1"), fg="blue"),sticky="w")
tkgrid(labelRcmdr(grFrame, text=gettextRcmdr("Group 2"), fg="blue"),sticky="w")
tkgrid(grFrame, sticky="nw", row=1, column=1)
muFrame <- tkframe(top)
tkgrid(labelRcmdr(muFrame, text=gettextRcmdr("Mean"), fg="blue"),sticky="w")
mu1Level <- tclVar(""); mu1Field <- ttkentry(muFrame, width="6", textvariable=mu1Level)
mu2Level <- tclVar(""); mu2Field <- ttkentry(muFrame, width="6", textvariable=mu2Level)
tkgrid(mu1Field, sticky="nw"); tkgrid(mu2Field, sticky="nw"); tkgrid(muFrame, sticky="nw", row=1, column=2)
nFrame <- tkframe(top)
tkgrid(labelRcmdr(nFrame, text=gettextRcmdr("N"), fg="blue"),sticky="w")
n1Level <- tclVar(""); n1Field <- ttkentry(nFrame, width="6", textvariable=n1Level)
n2Level <- tclVar(""); n2Field <- ttkentry(nFrame, width="6", textvariable=n2Level)
tkgrid(n1Field, sticky="nw"); tkgrid(n2Field, sticky="nw"); tkgrid(nFrame, sticky="nw", row=1, column=3)
sdFrame <- tkframe(top)
tkgrid(labelRcmdr(sdFrame, text=gettextRcmdr("St.dev."), fg="blue"),sticky="w")
sd1Level <- tclVar(""); sd1Field <- ttkentry(sdFrame, width="6", textvariable=sd1Level)
sd2Level <- tclVar(""); sd2Field <- ttkentry(sdFrame, width="6", textvariable=sd2Level)
tkgrid(sd1Field, sticky="nw"); tkgrid(sd2Field, sticky="nw"); tkgrid(sdFrame, sticky="nw", row=1, column=4)
mu0Frame <- tkframe(top)
tkgrid(labelRcmdr(mu0Frame, text=gettextRcmdr("mu1-mu2"), fg="blue"),sticky="w")
mu0Level <- tclVar("0"); mu0Field <- ttkentry(mu0Frame, width="6", textvariable=mu0Level)
tkgrid(mu0Field, sticky="nw"); tkgrid(mu0Frame, sticky="nw", row=2, column=1)
radioButtons(top, name="alternative", buttons=c("twosided", "less", "greater"), values=c("two.sided", "less", "greater"),
labels=gettextRcmdr(c("Two-sided", "Difference < mu1-mu2", "Difference > mu1-mu2")), title=gettextRcmdr("Alternative hypothesis"))
tkgrid(alternativeFrame, sticky="nw",row=3, column=1, columnspan=3)
confidenceFrame <- tkframe(top)
confidenceLevel <- tclVar(".95")
confidenceField <- ttkentry(confidenceFrame, width="6", textvariable=confidenceLevel)
tkgrid(labelRcmdr(confidenceFrame, text=gettextRcmdr("Confidence level "), fg="blue"),sticky="w")
tkgrid(confidenceField, sticky="w")
tkgrid(confidenceFrame, sticky="nw",row=3, column=4, columnspan=2)
radioButtons(top, name="variances", buttons=c("yes", "no"), values=c("TRUE", "FALSE"), initialValue="FALSE",
labels=gettextRcmdr(c("Yes", "No")), title=gettextRcmdr("Assume equal variances?"))
tkgrid(variancesFrame, sticky="nw",row=3, column=6, columnspan=2)
tkgrid(buttonsFrame, sticky="w", row=4,column=1, columnspan=6)
dialogSuffix(rows=4, columns=7)
}
#################################
# One sample t-test (summarized data)
oneSamplesTTestSum <- function(){
initializeDialog(title=gettextRcmdr("One sample t-test"))
onOK <- function(){ # Actions to perform
mu1 <- as.character(tclvalue(mu1Level))
n1 <- as.character(tclvalue(n1Level))
sd1 <- as.character(tclvalue(sd1Level))
mu0 <- as.character(tclvalue(mu0Level))
alternative <- as.character(tclvalue(alternativeVariable))
level <- tclvalue(confidenceLevel)
closeDialog()
doItAndPrint(paste("t_test_sum(means=", mu1, ", sds=", sd1, ", ns=", n1, ", alternative='",
alternative, "', mu=", mu0, ", conf.level=", level, ")", sep=""))
tkfocus(CommanderWindow())
}
# Set up GUI
OKCancelHelp(helpSubject="t_test")
grFrame <- tkframe(top);
tkgrid(labelRcmdr(grFrame, text=gettextRcmdr(""), fg="blue"),sticky="w")
tkgrid(labelRcmdr(grFrame, text=gettextRcmdr("Summaries"), fg="blue"),sticky="w")
tkgrid(grFrame, sticky="nw", row=1, column=1)
muFrame <- tkframe(top)
tkgrid(labelRcmdr(muFrame, text=gettextRcmdr("Mean"), fg="blue"),sticky="w")
mu1Level <- tclVar(""); mu1Field <- ttkentry(muFrame, width="6", textvariable=mu1Level)
tkgrid(mu1Field, sticky="nw"); tkgrid(muFrame, sticky="nw", row=1, column=2)
nFrame <- tkframe(top)
tkgrid(labelRcmdr(nFrame, text=gettextRcmdr("N"), fg="blue"),sticky="w")
n1Level <- tclVar(""); n1Field <- ttkentry(nFrame, width="6", textvariable=n1Level)
tkgrid(n1Field, sticky="nw"); tkgrid(nFrame, sticky="nw", row=1, column=3)
sdFrame <- tkframe(top)
tkgrid(labelRcmdr(sdFrame, text=gettextRcmdr("St.dev."), fg="blue"),sticky="w")
sd1Level <- tclVar(""); sd1Field <- ttkentry(sdFrame, width="6", textvariable=sd1Level)
tkgrid(sd1Field, sticky="nw"); tkgrid(sdFrame, sticky="nw", row=1, column=4)
mu0Frame <- tkframe(top)
tkgrid(labelRcmdr(mu0Frame, text=gettextRcmdr("mu0"), fg="blue"),sticky="w")
mu0Level <- tclVar("0"); mu0Field <- ttkentry(mu0Frame, width="6", textvariable=mu0Level)
tkgrid(mu0Field, sticky="nw"); tkgrid(mu0Frame, sticky="nw", row=2, column=1)
radioButtons(top, name="alternative", buttons=c("twosided", "less", "greater"), values=c("two.sided", "less", "greater"),
labels=gettextRcmdr(c("Two-sided", "True mean < mu0", "True mean > mu0")), title=gettextRcmdr("Alternative hypothesis"))
tkgrid(alternativeFrame, sticky="nw",row=3, column=1, columnspan=3)
confidenceFrame <- tkframe(top)
confidenceLevel <- tclVar(".95")
confidenceField <- ttkentry(confidenceFrame, width="6", textvariable=confidenceLevel)
tkgrid(labelRcmdr(confidenceFrame, text=gettextRcmdr("Confidence level"), fg="blue"),sticky="w")
tkgrid(confidenceField, sticky="w")
tkgrid(confidenceFrame, sticky="nw",row=3, column=4, columnspan=2)
tkgrid(buttonsFrame, sticky="w", row=4,column=1, columnspan=6)
dialogSuffix(rows=4, columns=7)
}
#################################
# Independent samples t-test
independentSamplesTTestNMBU <- function(){
initializeDialog(title=gettextRcmdr("Independent Samples t-Test"))
variablesFrame <- tkframe(top)
groupBox <- variableListBox(variablesFrame, TwoLevelFactors(), title=gettextRcmdr("Groups (pick one)"))
responseBox <- variableListBox(variablesFrame, Numeric(), title=gettextRcmdr("Response Variable (pick one)"))
onOK <- function(){
group <- getSelection(groupBox)
if (length(group) == 0) {
errorCondition(recall=independentSamplesTTest, message=gettextRcmdr("You must select a groups variable."))
return()
}
response <- getSelection(responseBox)
if (length(response) == 0) {
errorCondition(recall=independentSamplesTTest, message=gettextRcmdr("You must select a response variable."))
return()
}
alternative <- as.character(tclvalue(alternativeVariable))
level <- tclvalue(confidenceLevel)
variances <- as.character(tclvalue(variancesVariable))
mu0 <- as.character(tclvalue(mu0Level))
closeDialog()
doItAndPrint(paste("t_test(", response, "~", group,
", alternative='", alternative, "', mu=", mu0, ", conf.level=", level,
", var.equal=", variances,
", data=", ActiveDataSet(), ")", sep=""))
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="t_test")
optionsFrame <- tkframe(top)
radioButtons(optionsFrame, name="alternative", buttons=c("twosided", "less", "greater"), values=c("two.sided", "less", "greater"),
labels=gettextRcmdr(c("Two-sided", "Difference < mu0", "Difference > mu0")), title=gettextRcmdr("Alternative Hypothesis"))
confidenceFrame <- tkframe(optionsFrame)
confidenceLevel <- tclVar(".95")
confidenceField <- ttkentry(confidenceFrame, width="6", textvariable=confidenceLevel)
radioButtons(optionsFrame, name="variances", buttons=c("yes", "no"), values=c("TRUE", "FALSE"), initialValue="FALSE",
labels=gettextRcmdr(c("Yes", "No")), title=gettextRcmdr("Assume equal variances?"))
tkgrid(getFrame(groupBox), labelRcmdr(variablesFrame, text=" "), getFrame(responseBox), sticky="nw")
tkgrid(variablesFrame, sticky="nw")
mu0Frame <- tkframe(top)
tkgrid(labelRcmdr(mu0Frame, text=gettextRcmdr("mu1-mu2"), fg="blue"),sticky="w")
mu0Level <- tclVar("0"); mu0Field <- ttkentry(mu0Frame, width="6", textvariable=mu0Level)
tkgrid(mu0Field, sticky="nw"); tkgrid(mu0Frame, sticky="nw")
tkgrid(labelRcmdr(confidenceFrame, text=gettextRcmdr("Confidence Level"), fg="blue"),sticky="w")
tkgrid(confidenceField, sticky="w")
groupsLabel(groupsBox=groupBox)
tkgrid(alternativeFrame, labelRcmdr(optionsFrame, text=" "), confidenceFrame, labelRcmdr(optionsFrame, text=" "),
variancesFrame, sticky="nw")
tkgrid(optionsFrame, sticky="nw")
tkgrid(buttonsFrame, sticky="w")
dialogSuffix(rows=6, columns=1)
}
#################################
# Paired samples t-test
pairedTTestNMBU <- function(){
initializeDialog(title=gettextRcmdr("Paired t-Test"))
.numeric <- Numeric()
xBox <- variableListBox(top, .numeric, title=gettextRcmdr("First variable (pick one)"))
yBox <- variableListBox(top, .numeric, title=gettextRcmdr("Second variable (pick one)"))
onOK <- function(){
x <- getSelection(xBox)
y <- getSelection(yBox)
if (length(x) == 0 | length(y) == 0){
errorCondition(recall=pairedTTest, message=gettextRcmdr("You must select two variables."))
return()
}
if (x == y){
errorCondition(recall=pairedTTest, message=gettextRcmdr("Variables must be different."))
return()
}
alternative <- as.character(tclvalue(alternativeVariable))
level <- tclvalue(confidenceLevel)
mu <- tclvalue(muVariable)
closeDialog()
.activeDataSet <- ActiveDataSet()
doItAndPrint(paste("t_test(", .activeDataSet, "$", x, ", ",
.activeDataSet, "$", y,
", alternative='", alternative, "', mu=", mu, ", conf.level=", level,
", paired=TRUE)", sep=""))
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="t_test")
muFrame <- tkframe(top)
muVariable <- tclVar("0.0")
muField <- ttkentry(muFrame, width="8", textvariable=muVariable)
radioButtons(top, name="alternative", buttons=c("twosided", "less", "greater"), values=c("two.sided", "less", "greater"),
labels=gettextRcmdr(c("Two-sided", "Difference < mu0", "Difference > mu0")), title=gettextRcmdr("Alternative Hypothesis"))
confidenceFrame <- tkframe(top)
confidenceLevel <- tclVar(".95")
confidenceField <- ttkentry(confidenceFrame, width="6", textvariable=confidenceLevel)
tkgrid(getFrame(xBox), getFrame(yBox), sticky="nw")
tkgrid(labelRcmdr(muFrame, text=gettextRcmdr("Null hypothesis: mu = ")), muField, sticky="w")
tkgrid(muFrame, sticky="w")
tkgrid(labelRcmdr(confidenceFrame, text=gettextRcmdr("Confidence Level"), fg="blue"))
tkgrid(confidenceField, sticky="w")
tkgrid(alternativeFrame, confidenceFrame, sticky="nw")
tkgrid(buttonsFrame, columnspan=2, sticky="w")
dialogSuffix(rows=4, columns=2)
}
#################################
# Single sample t-test
singleSampleTTestNMBU <- function(){
initializeDialog(title=gettextRcmdr("Single-Sample t-Test"))
xBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Variable (pick one)"))
onOK <- function(){
x <- getSelection(xBox)
if (length(x) == 0){
errorCondition(recall=singleSampleTTest, message=gettextRcmdr("You must select a variable."))
return()
}
alternative <- as.character(tclvalue(alternativeVariable))
level <- tclvalue(confidenceLevel)
mu <- tclvalue(muVariable)
closeDialog()
doItAndPrint(paste("t_test(", ActiveDataSet(), "$", x,
", alternative='", alternative, "', mu=", mu, ", conf.level=", level,
")", sep=""))
tkdestroy(top)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="t_test")
radioButtons(top, name="alternative", buttons=c("twosided", "less", "greater"), values=c("two.sided", "less", "greater"),
labels=gettextRcmdr(c("Population mean != mu0", "Population mean < mu0", "Population mean > mu0")),
title=gettextRcmdr("Alternative Hypothesis"))
rightFrame <- tkframe(top)
confidenceFrame <- tkframe(rightFrame)
confidenceLevel <- tclVar(".95")
confidenceField <- ttkentry(confidenceFrame, width="6", textvariable=confidenceLevel)
muFrame <- tkframe(rightFrame)
muVariable <- tclVar("0.0")
muField <- ttkentry(muFrame, width="8", textvariable=muVariable)
tkgrid(getFrame(xBox), sticky="nw")
tkgrid(labelRcmdr(rightFrame, text=""), sticky="w")
tkgrid(labelRcmdr(muFrame, text=gettextRcmdr("Null hypothesis: mu = ")), muField, sticky="w")
tkgrid(muFrame, sticky="w")
tkgrid(labelRcmdr(confidenceFrame, text=gettextRcmdr("Confidence Level: ")), confidenceField, sticky="w")
tkgrid(confidenceFrame, sticky="w")
tkgrid(alternativeFrame, rightFrame, sticky="nw")
tkgrid(buttonsFrame, columnspan=2, sticky="w")
tkgrid.configure(confidenceField, sticky="e")
dialogSuffix(rows=4, columns=2)
}
#################################
# Two sample z-test (summarized data)
twoSamplesZTestSum <- function(){
initializeDialog(title=gettextRcmdr("Two samples z-test"))
onOK <- function(){ # Actions to perform
mu1 <- as.character(tclvalue(mu1Level))
n1 <- as.character(tclvalue(n1Level))
sd1 <- as.character(tclvalue(sd1Level))
mu2 <- as.character(tclvalue(mu2Level))
n2 <- as.character(tclvalue(n2Level))
sd2 <- as.character(tclvalue(sd2Level))
mu0 <- as.character(tclvalue(mu0Level))
alternative <- as.character(tclvalue(alternativeVariable))
level <- tclvalue(confidenceLevel)
variances <- as.character(tclvalue(variancesVariable))
closeDialog()
doItAndPrint(paste("z_test_sum(means=c(", mu1,",",mu2, "), sds=c(", sd1,",",sd2, "), ns=c(", n1,",",n2, "), alternative='",
alternative, "', mu=", mu0, ", var.equal=", variances, ", conf.level=", level, ")", sep=""))
tkfocus(CommanderWindow())
}
# Set up GUI
OKCancelHelp(helpSubject="t_test")
grFrame <- tkframe(top);
tkgrid(labelRcmdr(grFrame, text=gettextRcmdr(""), fg="blue"),sticky="w")
tkgrid(labelRcmdr(grFrame, text=gettextRcmdr("Group 1"), fg="blue"),sticky="w")
tkgrid(labelRcmdr(grFrame, text=gettextRcmdr("Group 2"), fg="blue"),sticky="w")
tkgrid(grFrame, sticky="nw", row=1, column=1)
muFrame <- tkframe(top)
tkgrid(labelRcmdr(muFrame, text=gettextRcmdr("Mean"), fg="blue"),sticky="w")
mu1Level <- tclVar(""); mu1Field <- ttkentry(muFrame, width="6", textvariable=mu1Level)
mu2Level <- tclVar(""); mu2Field <- ttkentry(muFrame, width="6", textvariable=mu2Level)
tkgrid(mu1Field, sticky="nw"); tkgrid(mu2Field, sticky="nw"); tkgrid(muFrame, sticky="nw", row=1, column=2)
nFrame <- tkframe(top)
tkgrid(labelRcmdr(nFrame, text=gettextRcmdr("N"), fg="blue"),sticky="w")
n1Level <- tclVar(""); n1Field <- ttkentry(nFrame, width="6", textvariable=n1Level)
n2Level <- tclVar(""); n2Field <- ttkentry(nFrame, width="6", textvariable=n2Level)
tkgrid(n1Field, sticky="nw"); tkgrid(n2Field, sticky="nw"); tkgrid(nFrame, sticky="nw", row=1, column=3)
sdFrame <- tkframe(top)
tkgrid(labelRcmdr(sdFrame, text=gettextRcmdr("St.dev."), fg="blue"),sticky="w")
sd1Level <- tclVar(""); sd1Field <- ttkentry(sdFrame, width="6", textvariable=sd1Level)
sd2Level <- tclVar(""); sd2Field <- ttkentry(sdFrame, width="6", textvariable=sd2Level)
tkgrid(sd1Field, sticky="nw"); tkgrid(sd2Field, sticky="nw"); tkgrid(sdFrame, sticky="nw", row=1, column=4)
mu0Frame <- tkframe(top)
tkgrid(labelRcmdr(mu0Frame, text=gettextRcmdr("mu1-mu2"), fg="blue"),sticky="w")
mu0Level <- tclVar("0"); mu0Field <- ttkentry(mu0Frame, width="6", textvariable=mu0Level)
tkgrid(mu0Field, sticky="nw"); tkgrid(mu0Frame, sticky="nw", row=2, column=1)
radioButtons(top, name="alternative", buttons=c("twosided", "less", "greater"), values=c("two.sided", "less", "greater"),
labels=gettextRcmdr(c("Two-sided", "Difference < mu1-mu2", "Difference > mu1-mu2")), title=gettextRcmdr("Alternative hypothesis"))
tkgrid(alternativeFrame, sticky="nw",row=3, column=1, columnspan=3)
confidenceFrame <- tkframe(top)
confidenceLevel <- tclVar(".95")
confidenceField <- ttkentry(confidenceFrame, width="6", textvariable=confidenceLevel)
tkgrid(labelRcmdr(confidenceFrame, text=gettextRcmdr("Confidence level "), fg="blue"),sticky="w")
tkgrid(confidenceField, sticky="w")
tkgrid(confidenceFrame, sticky="nw",row=3, column=4, columnspan=2)
radioButtons(top, name="variances", buttons=c("yes", "no"), values=c("TRUE", "FALSE"), initialValue="FALSE",
labels=gettextRcmdr(c("Yes", "No")), title=gettextRcmdr("Assume equal variances?"))
tkgrid(variancesFrame, sticky="nw",row=3, column=6, columnspan=2)
tkgrid(buttonsFrame, sticky="w", row=4,column=1, columnspan=6)
dialogSuffix(rows=4, columns=7)
}
#################################
# One sample z-test (summarized data)
oneSamplesZTestSum <- function(){
initializeDialog(title=gettextRcmdr("One sample z-test"))
onOK <- function(){ # Actions to perform
mu1 <- as.character(tclvalue(mu1Level))
n1 <- as.character(tclvalue(n1Level))
sd1 <- as.character(tclvalue(sd1Level))
mu0 <- as.character(tclvalue(mu0Level))
alternative <- as.character(tclvalue(alternativeVariable))
level <- tclvalue(confidenceLevel)
closeDialog()
doItAndPrint(paste("z_test_sum(means=", mu1, ", sds=", sd1, ", ns=", n1, ", alternative='",
alternative, "', mu=", mu0, ", conf.level=", level, ")", sep=""))
tkfocus(CommanderWindow())
}
# Set up GUI
OKCancelHelp(helpSubject="t_test")
grFrame <- tkframe(top);
tkgrid(labelRcmdr(grFrame, text=gettextRcmdr(""), fg="blue"),sticky="w")
tkgrid(labelRcmdr(grFrame, text=gettextRcmdr("Summaries"), fg="blue"),sticky="w")
tkgrid(grFrame, sticky="nw", row=1, column=1)
muFrame <- tkframe(top)
tkgrid(labelRcmdr(muFrame, text=gettextRcmdr("Mean"), fg="blue"),sticky="w")
mu1Level <- tclVar(""); mu1Field <- ttkentry(muFrame, width="6", textvariable=mu1Level)
tkgrid(mu1Field, sticky="nw"); tkgrid(muFrame, sticky="nw", row=1, column=2)
nFrame <- tkframe(top)
tkgrid(labelRcmdr(nFrame, text=gettextRcmdr("N"), fg="blue"),sticky="w")
n1Level <- tclVar(""); n1Field <- ttkentry(nFrame, width="6", textvariable=n1Level)
tkgrid(n1Field, sticky="nw"); tkgrid(nFrame, sticky="nw", row=1, column=3)
sdFrame <- tkframe(top)
tkgrid(labelRcmdr(sdFrame, text=gettextRcmdr("St.dev."), fg="blue"),sticky="w")
sd1Level <- tclVar(""); sd1Field <- ttkentry(sdFrame, width="6", textvariable=sd1Level)
tkgrid(sd1Field, sticky="nw"); tkgrid(sdFrame, sticky="nw", row=1, column=4)
mu0Frame <- tkframe(top)
tkgrid(labelRcmdr(mu0Frame, text=gettextRcmdr("mu0"), fg="blue"),sticky="w")
mu0Level <- tclVar("0"); mu0Field <- ttkentry(mu0Frame, width="6", textvariable=mu0Level)
tkgrid(mu0Field, sticky="nw"); tkgrid(mu0Frame, sticky="nw", row=2, column=1)
radioButtons(top, name="alternative", buttons=c("twosided", "less", "greater"), values=c("two.sided", "less", "greater"),
labels=gettextRcmdr(c("Two-sided", "True mean < mu0", "True mean > mu0")), title=gettextRcmdr("Alternative hypothesis"))
tkgrid(alternativeFrame, sticky="nw",row=3, column=1, columnspan=3)
confidenceFrame <- tkframe(top)
confidenceLevel <- tclVar(".95")
confidenceField <- ttkentry(confidenceFrame, width="6", textvariable=confidenceLevel)
tkgrid(labelRcmdr(confidenceFrame, text=gettextRcmdr("Confidence level"), fg="blue"),sticky="w")
tkgrid(confidenceField, sticky="w")
tkgrid(confidenceFrame, sticky="nw",row=3, column=4, columnspan=2)
tkgrid(buttonsFrame, sticky="w", row=4,column=1, columnspan=6)
dialogSuffix(rows=4, columns=7)
}
#################################
# Independent samples z-test
independentSamplesZTestNMBU <- function(){
initializeDialog(title=gettextRcmdr("Independent Samples z-Test"))
variablesFrame <- tkframe(top)
groupBox <- variableListBox(variablesFrame, TwoLevelFactors(), title=gettextRcmdr("Groups (pick one)"))
responseBox <- variableListBox(variablesFrame, Numeric(), title=gettextRcmdr("Response Variable (pick one)"))
onOK <- function(){
sd1 <- as.character(tclvalue(sd1Level))
sd2 <- as.character(tclvalue(sd2Level))
if(sd1==gettextRcmdr("") || sd1==gettextRcmdr("")){
errorCondition(recall=independentSamplesZTest, message=gettextRcmdr("You must specify both standard deviations."))
}
sd1 <- as.numeric(sd1)
sd2 <- as.numeric(sd2)
group <- getSelection(groupBox)
if (length(group) == 0) {
errorCondition(recall=independentSamplesZTest, message=gettextRcmdr("You must select a groups variable."))
return()
}
response <- getSelection(responseBox)
if (length(response) == 0) {
errorCondition(recall=independentSamplesZTest, message=gettextRcmdr("You must select a response variable."))
return()
}
alternative <- as.character(tclvalue(alternativeVariable))
level <- tclvalue(confidenceLevel)
variances <- as.character(tclvalue(variancesVariable))
mu0 <- as.character(tclvalue(mu0Level))
closeDialog()
doItAndPrint(paste("z.test(", response, "~", group,
", alternative='", alternative, "', mu=", mu0, ", conf.level=", level,
", var.equal=", variances,
", data=", ActiveDataSet(), ", sds=c(", sd1, ",", sd2, "))", sep=""))
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="t_test")
optionsFrame <- tkframe(top)
radioButtons(optionsFrame, name="alternative", buttons=c("twosided", "less", "greater"), values=c("two.sided", "less", "greater"),
labels=gettextRcmdr(c("Two-sided", "Difference < mu0", "Difference > mu0")), title=gettextRcmdr("Alternative Hypothesis"))
confidenceFrame <- tkframe(optionsFrame)
confidenceLevel <- tclVar(".95")
confidenceField <- ttkentry(confidenceFrame, width="6", textvariable=confidenceLevel)
radioButtons(optionsFrame, name="variances", buttons=c("yes", "no"), values=c("TRUE", "FALSE"), initialValue="FALSE",
labels=gettextRcmdr(c("Yes", "No")), title=gettextRcmdr("Assume equal variances?"))
tkgrid(getFrame(groupBox), labelRcmdr(variablesFrame, text=" "), getFrame(responseBox), sticky="nw")
tkgrid(variablesFrame, sticky="nw")
mu0Frame <- tkframe(top)
tkgrid(labelRcmdr(mu0Frame, text=gettextRcmdr("mu1-mu2"), fg="blue"),sticky="w")
mu0Level <- tclVar("0"); mu0Field <- ttkentry(mu0Frame, width="6", textvariable=mu0Level)
tkgrid(mu0Field, sticky="nw"); tkgrid(mu0Frame, sticky="nw")
tkgrid(labelRcmdr(confidenceFrame, text=gettextRcmdr("Confidence Level"), fg="blue"),sticky="w")
tkgrid(confidenceField, sticky="w")
groupsLabel(groupsBox=groupBox)
tkgrid(alternativeFrame, labelRcmdr(optionsFrame, text=" "), confidenceFrame, labelRcmdr(optionsFrame, text=" "),
variancesFrame, sticky="nw")
tkgrid(optionsFrame, sticky="nw")
sdFrame <- tkframe(top)
tkgrid(labelRcmdr(sdFrame, text=gettextRcmdr("Known st.dev."), fg="blue"),sticky="w")
sd1Level <- tclVar(""); sd1Field <- ttkentry(sdFrame, width="6", textvariable=sd1Level)
sd2Level <- tclVar(""); sd2Field <- ttkentry(sdFrame, width="6", textvariable=sd2Level)
tkgrid(sd1Field, sd2Field, sticky="w"); tkgrid(sdFrame, sticky="nw")
tkgrid(buttonsFrame, sticky="w")
dialogSuffix(rows=6, columns=1)
}
#################################
# Paired samples z-test
pairedZTestNMBU <- function(){
initializeDialog(title=gettextRcmdr("Paired z-Test"))
.numeric <- Numeric()
xBox <- variableListBox(top, .numeric, title=gettextRcmdr("First variable (pick one)"))
yBox <- variableListBox(top, .numeric, title=gettextRcmdr("Second variable (pick one)"))
onOK <- function(){
x <- getSelection(xBox)
y <- getSelection(yBox)
sd1 <- as.character(tclvalue(sd1Level))
z.test <- FALSE
if(sd1==gettextRcmdr("")){
errorCondition(recall=pairedZTest, message=gettextRcmdr("You must specify a standard deviation."))
}
sd1 <- as.numeric(sd1)
if (length(x) == 0 | length(y) == 0){
errorCondition(recall=pairedZTest, message=gettextRcmdr("You must select two variables."))
return()
}
if (x == y){
errorCondition(recall=pairedZTest, message=gettextRcmdr("Variables must be different."))
return()
}
alternative <- as.character(tclvalue(alternativeVariable))
level <- tclvalue(confidenceLevel)
mu <- tclvalue(muVariable)
closeDialog()
.activeDataSet <- ActiveDataSet()
doItAndPrint(paste("z.test(", .activeDataSet, "$", x, ", ",
.activeDataSet, "$", y,
", alternative='", alternative, "', conf.level=", level,
", paired=TRUE, sds=", sd1, ")", sep=""))
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="t_test")
muFrame <- tkframe(top)
muVariable <- tclVar("0.0")
muField <- ttkentry(muFrame, width="8", textvariable=muVariable)
radioButtons(top, name="alternative", buttons=c("twosided", "less", "greater"), values=c("two.sided", "less", "greater"),
labels=gettextRcmdr(c("Two-sided", "Difference < mu0", "Difference > mu0")), title=gettextRcmdr("Alternative Hypothesis"))
confidenceFrame <- tkframe(top)
confidenceLevel <- tclVar(".95")
confidenceField <- ttkentry(confidenceFrame, width="6", textvariable=confidenceLevel)
tkgrid(getFrame(xBox), getFrame(yBox), sticky="nw")
tkgrid(labelRcmdr(muFrame, text=gettextRcmdr("Null hypothesis: mu = ")), muField, sticky="w")
tkgrid(muFrame, sticky="w")
tkgrid(labelRcmdr(confidenceFrame, text=gettextRcmdr("Confidence Level"), fg="blue"))
tkgrid(confidenceField, sticky="w")
tkgrid(alternativeFrame, confidenceFrame, sticky="nw")
sdFrame <- tkframe(top)
tkgrid(labelRcmdr(sdFrame, text=gettextRcmdr("Known st.dev."), fg="blue"),sticky="w")
sd1Level <- tclVar(""); sd1Field <- ttkentry(sdFrame, width="6", textvariable=sd1Level)
tkgrid(sd1Field, sticky="w"); tkgrid(sdFrame, sticky="nw")
tkgrid(buttonsFrame, columnspan=2, sticky="w")
dialogSuffix(rows=5, columns=2)
}
#################################
# Single sample z-test
singleSampleZTestNMBU <- function(){
initializeDialog(title=gettextRcmdr("Single-Sample z-Test"))
xBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Variable (pick one)"))
onOK <- function(){
x <- getSelection(xBox)
sd1 <- as.character(tclvalue(sd1Level))
if(sd1==gettextRcmdr("")){
errorCondition(recall=singleSampleZTest, message=gettextRcmdr("You must specify a standard deviation."))
}
sd1 <- as.numeric(sd1)
if (length(x) == 0){
errorCondition(recall=singleSampleZTest, message=gettextRcmdr("You must select a variable."))
return()
}
alternative <- as.character(tclvalue(alternativeVariable))
level <- tclvalue(confidenceLevel)
mu <- tclvalue(muVariable)
closeDialog()
doItAndPrint(paste("z.test(", ActiveDataSet(), "$", x,
", alternative='", alternative, "', mu=", mu, ", conf.level=", level,
", sds=", sd1,")", sep=""))
tkdestroy(top)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="t_test")
radioButtons(top, name="alternative", buttons=c("twosided", "less", "greater"), values=c("two.sided", "less", "greater"),
labels=gettextRcmdr(c("Population mean != mu0", "Population mean < mu0", "Population mean > mu0")),
title=gettextRcmdr("Alternative Hypothesis"))
rightFrame <- tkframe(top)
confidenceFrame <- tkframe(rightFrame)
confidenceLevel <- tclVar(".95")
confidenceField <- ttkentry(confidenceFrame, width="6", textvariable=confidenceLevel)
muFrame <- tkframe(rightFrame)
muVariable <- tclVar("0.0")
muField <- ttkentry(muFrame, width="8", textvariable=muVariable)
tkgrid(getFrame(xBox), sticky="nw")
tkgrid(labelRcmdr(rightFrame, text=""), sticky="w")
tkgrid(labelRcmdr(muFrame, text=gettextRcmdr("Null hypothesis: mu = ")), muField, sticky="w")
tkgrid(muFrame, sticky="w")
tkgrid(labelRcmdr(confidenceFrame, text=gettextRcmdr("Confidence Level: ")), confidenceField, sticky="w")
tkgrid(confidenceFrame, sticky="w")
tkgrid(alternativeFrame, rightFrame, sticky="nw")
sdFrame <- tkframe(top)
tkgrid(labelRcmdr(sdFrame, text=gettextRcmdr("Known st.dev."), fg="blue"),sticky="w")
sd1Level <- tclVar(""); sd1Field <- ttkentry(sdFrame, width="6", textvariable=sd1Level)
tkgrid(sd1Field, sticky="w"); tkgrid(sdFrame, sticky="nw")
tkgrid(buttonsFrame, columnspan=2, sticky="w")
tkgrid.configure(confidenceField, sticky="e")
dialogSuffix(rows=5, columns=2)
}
#################################
# Unstacked two sample t-test
twoSamplesTTest <- function(){
initializeDialog(title=gettextRcmdr("Two Samples t-Test"))
variablesFrame <- tkframe(top)
.numeric <- Numeric()
xBox <- variableListBox(variablesFrame, .numeric, title=gettextRcmdr("First variable (pick one)"))
yBox <- variableListBox(variablesFrame, .numeric, title=gettextRcmdr("Second variable (pick one)"))
onOK <- function(){ # Actions to perform
x <- getSelection(xBox)
y <- getSelection(yBox)
if (length(x) == 0 | length(y) == 0){
errorCondition(recall=twoSamplesTTest, message=gettextRcmdr("You must select two variables."))
return()
}
if (x == y){
errorCondition(recall=twoSamplesTTest, message=gettextRcmdr("Variables must be different."))
return()
}
alternative <- as.character(tclvalue(alternativeVariable))
level <- tclvalue(confidenceLevel)
variances <- as.character(tclvalue(variancesVariable))
mu <- tclvalue(mu0Level)
closeDialog()
.activeDataSet <- ActiveDataSet()
doItAndPrint(paste("t_test(", .activeDataSet, "$", x, ", ",
.activeDataSet, "$", y,
", alternative='", alternative, "', mu=", mu, ", conf.level=", level,
", var.equal=", variances,
", data=", ActiveDataSet(), ")", sep=""))
tkfocus(CommanderWindow())
}
# Set up GUI
OKCancelHelp(helpSubject="t_test")
optionsFrame <- tkframe(top)
radioButtons(optionsFrame, name="alternative", buttons=c("twosided", "less", "greater"), values=c("two.sided", "less", "greater"),
labels=gettextRcmdr(c("Two-sided", "Difference < mu0", "Difference > mu0")), title=gettextRcmdr("Alternative Hypothesis"))
confidenceFrame <- tkframe(optionsFrame)
confidenceLevel <- tclVar(".95")
confidenceField <- ttkentry(confidenceFrame, width="6", textvariable=confidenceLevel)
radioButtons(optionsFrame, name="variances", buttons=c("yes", "no"), values=c("TRUE", "FALSE"), initialValue="FALSE",
labels=gettextRcmdr(c("Yes", "No")), title=gettextRcmdr("Assume equal variances?"))
tkgrid(getFrame(xBox), getFrame(yBox), sticky="nw")
tkgrid(variablesFrame, sticky="nw")
mu0Frame <- tkframe(top)
tkgrid(labelRcmdr(mu0Frame, text=gettextRcmdr("mu0"), fg="blue"),sticky="w")
mu0Level <- tclVar("0"); mu0Field <- ttkentry(mu0Frame, width="6", textvariable=mu0Level)
tkgrid(mu0Field, sticky="nw"); tkgrid(mu0Frame, sticky="nw")
tkgrid(labelRcmdr(confidenceFrame, text=gettextRcmdr("Confidence Level"), fg="blue"),sticky="w")
tkgrid(confidenceField, sticky="w")
tkgrid(alternativeFrame, labelRcmdr(optionsFrame, text=" "), confidenceFrame, labelRcmdr(optionsFrame, text=" "),
variancesFrame, sticky="nw")
tkgrid(optionsFrame, sticky="nw")
tkgrid(buttonsFrame, sticky="w")
dialogSuffix(rows=4, columns=1)
}
#################################
# Unstacked two sample z-test
twoSamplesZTest <- function(){
initializeDialog(title=gettextRcmdr("Two Samples z-Test"))
variablesFrame <- tkframe(top)
.numeric <- Numeric()
xBox <- variableListBox(variablesFrame, .numeric, title=gettextRcmdr("First variable (pick one)"))
yBox <- variableListBox(variablesFrame, .numeric, title=gettextRcmdr("Second variable (pick one)"))
onOK <- function(){ # Actions to perform
x <- getSelection(xBox)
y <- getSelection(yBox)
sd1 <- as.character(tclvalue(sd1Level))
sd2 <- as.character(tclvalue(sd2Level))
if(sd1==gettextRcmdr("") || sd1==gettextRcmdr("")){
errorCondition(recall=twoSamplesZTest, message=gettextRcmdr("You must specify both standard deviations."))
}
sd1 <- as.numeric(sd1)
sd2 <- as.numeric(sd2)
if (length(x) == 0 | length(y) == 0){
errorCondition(recall=twoSamplesTTest, message=gettextRcmdr("You must select two variables."))
return()
}
if (x == y){
errorCondition(recall=twoSamplesTTest, message=gettextRcmdr("Variables must be different."))
return()
}
alternative <- as.character(tclvalue(alternativeVariable))
level <- tclvalue(confidenceLevel)
variances <- as.character(tclvalue(variancesVariable))
mu <- tclvalue(mu0Level)
closeDialog()
.activeDataSet <- ActiveDataSet()
doItAndPrint(paste("z.test(", .activeDataSet, "$", x, ", ",
.activeDataSet, "$", y,
", alternative='", alternative, "', mu=", mu, ", conf.level=", level,
", var.equal=", variances,
", data=", ActiveDataSet(), ", sds=c(", sd1, ",", sd2, "))", sep=""))
tkfocus(CommanderWindow())
}
# Set up GUI
OKCancelHelp(helpSubject="t_test")
optionsFrame <- tkframe(top)
radioButtons(optionsFrame, name="alternative", buttons=c("twosided", "less", "greater"), values=c("two.sided", "less", "greater"),
labels=gettextRcmdr(c("Two-sided", "Difference < mu0", "Difference > mu0")), title=gettextRcmdr("Alternative Hypothesis"))
confidenceFrame <- tkframe(optionsFrame)
confidenceLevel <- tclVar(".95")
confidenceField <- ttkentry(confidenceFrame, width="6", textvariable=confidenceLevel)
radioButtons(optionsFrame, name="variances", buttons=c("yes", "no"), values=c("TRUE", "FALSE"), initialValue="FALSE",
labels=gettextRcmdr(c("Yes", "No")), title=gettextRcmdr("Assume equal variances?"))
tkgrid(getFrame(xBox), getFrame(yBox), sticky="nw")
tkgrid(variablesFrame, sticky="nw")
mu0Frame <- tkframe(top)
tkgrid(labelRcmdr(mu0Frame, text=gettextRcmdr("mu0"), fg="blue"),sticky="w")
mu0Level <- tclVar("0"); mu0Field <- ttkentry(mu0Frame, width="6", textvariable=mu0Level)
tkgrid(mu0Field, sticky="nw"); tkgrid(mu0Frame, sticky="nw")
tkgrid(labelRcmdr(confidenceFrame, text=gettextRcmdr("Confidence Level"), fg="blue"),sticky="w")
tkgrid(confidenceField, sticky="w")
tkgrid(alternativeFrame, labelRcmdr(optionsFrame, text=" "), confidenceFrame, labelRcmdr(optionsFrame, text=" "),
variancesFrame, sticky="nw")
tkgrid(optionsFrame, sticky="nw")
sdFrame <- tkframe(top)
tkgrid(labelRcmdr(sdFrame, text=gettextRcmdr("Known st.dev."), fg="blue"),sticky="w")
sd1Level <- tclVar(""); sd1Field <- ttkentry(sdFrame, width="6", textvariable=sd1Level)
sd2Level <- tclVar(""); sd2Field <- ttkentry(sdFrame, width="6", textvariable=sd2Level)
tkgrid(sd1Field, sd2Field, sticky="w"); tkgrid(sdFrame, sticky="nw")
tkgrid(buttonsFrame, sticky="w")
dialogSuffix(rows=5, columns=1)
}
#####################################
# Create simplex mixture design
simplex.analysis <- function(){
initializeDialog(title=gettextRcmdr("Create simplex mixture design"))
.numeric <- Numeric()
plotFrame <- tkframe(top)
variablesFrame <- tkframe(top)
x1Box <- variableListBox(variablesFrame, .numeric, title=gettextRcmdr("Left variable (pick one)"))
x2Box <- variableListBox(variablesFrame, .numeric, title=gettextRcmdr("Top variable (pick one)"))
x3Box <- variableListBox(variablesFrame, .numeric, title=gettextRcmdr("Right variable (pick one)"))
yBox <- variableListBox(variablesFrame, .numeric, title=gettextRcmdr("Response variable (pick one)"))
UpdateModelNumber()
modelName <- tclVar(paste("LinearModel.", getRcmdr("modelNumber"), sep=""))
modelFrame <- tkframe(top)
model <- ttkentry(modelFrame, width="20", textvariable=modelName)
formatFrame <- tkframe(top)
onOK <- function(){ # Actions to perform
x1 <- getSelection(x1Box)
x2 <- getSelection(x2Box)
x3 <- getSelection(x3Box)
y <- getSelection(yBox)
do.plot <- tclvalue(plotVariable)
linear <- as.character(tclvalue(linearVariable))
modelValue <- trim.blanks(tclvalue(modelName))
closeDialog()
if (0 == length(x1) || 0 == length(x2) || 0 == length(x3) || 0 == length(y)) {
errorCondition(recall=simplex.analysis, message=gettextRcmdr("Variables must be chosen from all boxes."))
return()
}
if (!is.valid.name(modelValue)){
errorCondition(recall=simplex.analysis, message=sprintf(gettextRcmdr('"%s" is not a valid name.'), modelValue), model=TRUE)
return()
}
.activeDataSet <- ActiveDataSet()
if(linear==gettextRcmdr("linear")){
formula1 <- paste("lm(", paste("formula(",y," ~ ",x1," + ",x2," + ",x3, " -1)", sep=""), sep="")
command <- paste(formula1, ", data=", .activeDataSet,")", sep="")
# logger(paste(modelValue, " <- ", command, sep=""))
# assign(modelValue, justDoIt(command), envir=.GlobalEnv)
doItAndPrint(paste(modelValue, " <- ", command, sep=""))
activeModel(modelValue)
doItAndPrint(paste("Anova(", modelValue, ", type='II')", sep=""))
} else {
formula1 <- paste("lm(", paste("formula(",y," ~ (",x1," + ",x2," + ",x3, ")^2 -1)", sep=""), sep="")
command <- paste(formula1, ", data=", .activeDataSet,")", sep="")
# logger(paste(modelValue, " <- ", command, sep=""))
# assign(modelValue, justDoIt(command), envir=.GlobalEnv)
doItAndPrint(paste(modelValue, " <- ", command, sep=""))
activeModel(modelValue)
doItAndPrint(paste("Anova(", modelValue, ", type='II')", sep=""))
}
if(do.plot == gettextRcmdr("1")){
mixtureGUI()}
tkfocus(CommanderWindow())
}
# Set up GUI
OKCancelHelp(helpSubject="plot")
tkgrid(labelRcmdr(modelFrame, text=gettextRcmdr("Enter name for model:")), model, sticky="w")
tkgrid(modelFrame, sticky="w", column=1, row=1, columnspan=2)
tkgrid(getFrame(x1Box), labelRcmdr(variablesFrame, text=" "), getFrame(x2Box), labelRcmdr(variablesFrame, text=" "), getFrame(x3Box), sticky="nw")
tkgrid(getFrame(yBox), sticky="nw")
tkgrid(variablesFrame, sticky="nw", row=2, column=1, columnspan=2)
radioButtonsNMBU(formatFrame,name="linear", buttons=c("linear", "quadratic"), values=c("linear", "quadratic"), initialValue = "linear",
labels=gettextRcmdr(c("Linear model", "Quadratic model")))
tkgrid(formatFrame, row=3, column=1, columnspan=1, rowspan=1, sticky="w")
checkBoxes(frame="plotFrame", boxes=c("plot"), initialValues=c("0"), labels=gettextRcmdr(c("Plot responce surface")))
tkgrid(plotFrame, row=4, column=1, columnspan=1, rowspan=1, sticky="w")
tkgrid(buttonsFrame, sticky="w", row=5, column=1, columnspan=1)
dialogSuffix(rows=5, columns=1)
}
#####################################
# Relevant Component Analysis (after Helland and Almøy, 1994)
RelComp <- function(){
initializeDialog(title=gettextRcmdr("Relevant Components Plot"))
variablesFrame1 <- tkframe(top)
.numeric <- Numeric()
.variable <- Variables()
xBox <- variableListBox(variablesFrame1, .numeric, selectmode="multiple",title=gettextRcmdr("Explanatory variables (pick two or more)"))
yBox <- variableListBox(variablesFrame1, .variable, title=gettextRcmdr("Response variable (pick one)"))
subsetBox()
compFrame <- tkframe(top)
compVar <- tclVar("3")
compEntry <- ttkentry(compFrame, width="3", textvariable=compVar)
checkBoxes(frame="optionsFrame", boxes=c("center", "scale"), initialValues=c("1", "0"),
labels=gettextRcmdr(c("Center predictors", "Scale predictors")))
onOK <- function(){ # Actions to perform
x <- getSelection(xBox)
nvar <- length(x)
y <- getSelection(yBox)
center <- tclvalue(centerVariable)
scale <- tclvalue(scaleVariable)
subset <- tclvalue(subsetVariable)
ncomp <- tclvalue(compVar)
closeDialog()
if (2 > nvar) {
errorCondition(recall=Relcomp, message=gettextRcmdr("Fewer than 2 variables selected."))
return()
}
if (is.element(y, x)) {
UpdateModelNumber(-1)
errorCondition(recall=plsRegressionModel, message=gettextRcmdr("Response and explanatory variables must be different."))
return()
}
subset <- if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) ", subset=NULL" else paste(", subset=", subset, sep="")
if(trim.blanks(ncomp) == gettextRcmdr("")){
ncomp <- nvar
}
ncomp <- paste(", ncomp=",ncomp,sep="")
.activeDataSet <- ActiveDataSet()
docenter <- ifelse(center == "1",TRUE, FALSE)
doscale <- ifelse(scale == "1",TRUE, FALSE)
x <- paste('"', x, '"', sep="")
getY <- paste(.activeDataSet,"$",y,sep="")
getX <- paste(.activeDataSet, "[,c(",paste(x, collapse=","),")]",sep="")
command <- paste("plotprops(",getY,",",getX,", doscaleX=",doscale,",docenterX=",docenter,ncomp,subset,")",sep="")
justDoIt(command)
logger(command)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="plot", model=TRUE)
tkgrid(variablesFrame1, row=1, columnspan=2, sticky="n")
tkgrid(getFrame(yBox), row=1, column=1, sticky="nw")
tkgrid(getFrame(xBox), row=1, column=2, sticky="nw")
tkgrid(subsetFrame, sticky="w")
tkgrid(labelRcmdr(compFrame, text=gettextRcmdr("Number of components")), compEntry, sticky="w")
tkgrid(compFrame, sticky="w")
tkgrid(optionsFrame, sticky="w")
tkgrid(buttonsFrame, sticky="w")
dialogSuffix(rows=6, columns=2)
}
#####################################
# Tally of discrete variable
tally.GUI <- function(){
initializeDialog(title=gettextRcmdr("Tally of discrete variable"))
.numeric <- Numeric()
plotFrame <- tkframe(top)
variablesFrame <- tkframe(top)
xBox <- variableListBox(variablesFrame, .numeric, title=gettextRcmdr("Tally variable (pick one)"))
onOK <- function(){ # Actions to perform
x <- getSelection(xBox)
closeDialog()
if (1 != length(x)) {
errorCondition(recall=tally.GUI, message=gettextRcmdr("Exactly one variable must be chosen"))
return()
}
command <- paste("tally(",ActiveDataSet(), "$", x,")", sep="")
doItAndPrint(command)
tkfocus(CommanderWindow())
}
# Set up GUI
OKCancelHelp(helpSubject="summary")
tkgrid(getFrame(xBox), sticky="nw")
tkgrid(variablesFrame, sticky="nw", row=1, column=1, columnspan=1)
tkgrid(buttonsFrame, sticky="w", row=2, column=1, columnspan=1)
dialogSuffix(rows=2, columns=1)
}
####################################
# Power computation for t statistics
powerTtest <- function(){
initializeDialog(title=gettextRcmdr("Power calculations for one and two sample t tests"))
onOK <- function(){ # Actions to perform
nVal <- tclvalue(nLevel)
deltaVal <- tclvalue(deltaLevel)
sdVal <- tclvalue(sdLevel)
sigVal <- tclvalue(sigLevel)
powVal <- tclvalue(powLevel)
nBlank <- 0
if(trim.blanks(nVal) != gettextRcmdr("")){
nBlank <- nBlank + 1
} else {nVal <- "NULL"}
if(trim.blanks(deltaVal) != gettextRcmdr("")){
nBlank <- nBlank + 1
} else {deltaVal <- "NULL"}
if(trim.blanks(sdVal) != gettextRcmdr("")){
nBlank <- nBlank + 1
} else {sdVal <- "NULL"}
if(trim.blanks(sigVal) != gettextRcmdr("")){
nBlank <- nBlank + 1
} else {sigVal <- "NULL"}
if(trim.blanks(powVal) != gettextRcmdr("")){
nBlank <- nBlank + 1
pow <- as.numeric(powVal)
if(pow<=0 || pow>=1){
errorCondition(recall=powerTtest, message=gettextRcmdr("Power must be between 0 and 1 if supplied."))
return()
}
} else {powVal <- "NULL"}
if(nBlank != 4){
errorCondition(recall=powerTtest, message=gettextRcmdr("Exactly one field must be left empty."))
return()
}
type <- as.character(tclvalue(typeVariable))
alternative <- as.character(tclvalue(alternativeVariable))
closeDialog()
command <- paste("power.t.test(n = ", nVal, ", delta = ", deltaVal, ", sd = ", sdVal, ", sig.level = ", sigVal, ", power = ", powVal, ", type = '", type, "', alternative = '", alternative, "')", sep="")
doItAndPrint(command)
#assign(".Table", justDoIt(command), envir=.GlobalEnv)
tkfocus(CommanderWindow())
}
# Set up GUI
nFrame <- tkframe(top)
nLevel <- tclVar("")
nField <- ttkentry(nFrame, width="6", textvariable=nLevel)
deltaFrame <- tkframe(top)
deltaLevel <- tclVar("")
deltaField <- ttkentry(deltaFrame, width="6", textvariable=deltaLevel)
sdFrame <- tkframe(top)
sdLevel <- tclVar("")
sdField <- ttkentry(sdFrame, width="6", textvariable=sdLevel)
sigFrame <- tkframe(top)
sigLevel <- tclVar("0.05")
sigField <- ttkentry(sigFrame, width="6", textvariable=sigLevel)
powFrame <- tkframe(top)
powLevel <- tclVar("")
powField <- ttkentry(powFrame, width="6", textvariable=powLevel)
tkgrid(labelRcmdr(nFrame, text=gettextRcmdr("# of samples:"), fg="blue"), sticky="nw")
tkgrid(nField, sticky="nw")
tkgrid(labelRcmdr(deltaFrame, text=gettextRcmdr("True difference:"), fg="blue"), sticky="nw")
tkgrid(deltaField, sticky="nw")
tkgrid(labelRcmdr(sdFrame, text=gettextRcmdr("Standard deviation:"), fg="blue"), sticky="nw")
tkgrid(sdField, sticky="nw")
tkgrid(labelRcmdr(sigFrame, text=gettextRcmdr("Significance level:"), fg="blue"), sticky="nw")
tkgrid(sigField, sticky="nw")
tkgrid(labelRcmdr(powFrame, text=gettextRcmdr("Power:"), fg="blue"), sticky="nw")
tkgrid(powField, sticky="nw")
tkgrid(nFrame, sticky="nw", row=1, column=1, columnspan=1)
tkgrid(deltaFrame, sticky="nw", row=1, column=2, columnspan=1)
tkgrid(sdFrame, sticky="nw", row=1, column=3, columnspan=1)
tkgrid(sigFrame, sticky="nw", row=2, column=1, columnspan=1)
tkgrid(powFrame, sticky="nw", row=2, column=2, columnspan=1)
radioButtons(top, name="type", buttons=c("twosample", "onesample", "Paired"), values=c("two.sample", "one.sample", "paired"),
labels=gettextRcmdr(c("Two sample", "One sample", "Paired")), title=gettextRcmdr("Type of t test"))
radioButtons(top, name="alternative", buttons=c("twosided", "onesided"), values=c("two.sided", "one.sided"),
labels=gettextRcmdr(c("Two-sided", "One-sided")), title=gettextRcmdr("Alternative"))
tkgrid(typeFrame, sticky="nw", row=3, column=1, columnspan=1)
tkgrid(alternativeFrame, sticky="nw", row=3, column=2, columnspan=2)
OKCancelHelp(helpSubject="power.t.test")
tkgrid(buttonsFrame, sticky="w", row=4, column=1, columnspan=3)
dialogSuffix(rows=4, columns=2)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.