Nothing
# Statistics Menu dialogs
# last modified 2022-06-27 by J. Fox
# Tables menu
twoWayTable <- function(){
Library("abind")
defaults <- list(initial.row=NULL, initial.column=NULL,
initial.percents="none", initial.chisq=1, initial.chisqComp=0, initial.expected=0,
initial.fisher=0, initial.subset=gettextRcmdr("<all valid cases>"), initial.tab=0)
dialog.values <- getDialog("twoWayTable", defaults)
initializeDialog(title=gettextRcmdr("Two-Way Table"), use.tabs=TRUE)
variablesFrame <- tkframe(dataTab)
.factors <- Factors()
rowBox <- variableListBox(variablesFrame, .factors, title=gettextRcmdr("Row variable (pick one)"),
initialSelection=varPosn(dialog.values$initial.row, "factor"))
columnBox <- variableListBox(variablesFrame, .factors, title=gettextRcmdr("Column variable (pick one)"),
initialSelection=varPosn(dialog.values$initial.column, "factor"))
subsetBox(dataTab, subset.expression=dialog.values$initial.subset)
onOK <- function(){
tab <- if (as.character(tkselect(notebook)) == dataTab$ID) 0 else 1
row <- getSelection(rowBox)
column <- getSelection(columnBox)
percents <- as.character(tclvalue(percentsVariable))
chisq <- tclvalue(chisqTestVariable)
chisqComp <- tclvalue(chisqComponentsVariable)
expected <- tclvalue(expFreqVariable)
fisher <- tclvalue(fisherTestVariable)
initial.subset <- subset <- tclvalue(subsetVariable)
subset <- if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) ""
else paste(", subset=", subset, sep="")
putDialog("twoWayTable", list(
initial.row=row,
initial.column=column,
initial.percents=percents, initial.chisq=chisq, initial.chisqComp=chisqComp,
initial.expected=expected, initial.fisher=fisher, initial.subset=initial.subset,
initial.tab=tab))
if (length(row) == 0 || length(column) == 0){
errorCondition(recall=twoWayTable, message=gettextRcmdr("You must select two variables."))
return()
}
if (row == column) {
errorCondition(recall=twoWayTable, message=gettextRcmdr("Row and column variables are the same."))
return()
}
closeDialog()
command <- paste("local({\n .Table <- xtabs(~", row, "+", column, ", data=", ActiveDataSet(),
subset, ')\n cat("\\nFrequency table:\\n")\n print(.Table)', sep="")
command.2 <- paste("local({\n .warn <- options(warn=-1)\n .Table <- xtabs(~", row, "+", column, ", data=", ActiveDataSet(),
subset, ")", sep="")
if (percents == "row")
command <- paste(command, '\n cat("\\nRow percentages:\\n")\n print(rowPercents(.Table))',
sep="")
else if (percents == "column")
command <- paste(command, '\n cat("\\nColumn percentages:\\n")\n print(colPercents(.Table))',
sep="")
else if (percents == "total")
command <- paste(command, '\n cat("\\nTotal percentages:\\n")\n print(totPercents(.Table))',
sep="")
if (chisq == 1) {
command <- paste(command, "\n .Test <- chisq.test(.Table, correct=FALSE)", sep="")
command.2 <- paste(command.2, "\n .Test <- chisq.test(.Table, correct=FALSE)", sep="")
command <- paste(command, "\n print(.Test)", sep="")
if (expected == 1)
command <- paste(command, '\n cat("\\nExpected counts:\\n")\n print(.Test$expected)', sep="")
if (chisqComp == 1) {
command <- paste(command, '\n cat("\\nChi-square components:\\n")\n print(round(.Test$residuals^2, 2))', sep="")
}
}
if (fisher == 1) command <- paste(command, "\n print(fisher.test(.Table))")
command <- paste(command, "\n})", sep="")
doItAndPrint(command)
if (chisq == 1){
command.2 <- paste(command.2, "\nputRcmdr('.expected.counts', .Test$expected)\n options(.warn)\n})")
justDoIt(command.2)
warnText <- NULL
expected <- getRcmdr(".expected.counts")
if (0 < (nlt1 <- sum(expected < 1))) warnText <- paste(nlt1,
gettextRcmdr("expected frequencies are less than 1"))
if (0 < (nlt5 <- sum(expected < 5))) warnText <- paste(warnText, "\n", nlt5,
gettextRcmdr(" expected frequencies are less than 5"), sep="")
if (!is.null(warnText)) Message(message=warnText,
type="warning")
}
insertRmdSection(paste0(gettextRmdHeader("Two-Way Contingency Table: "), row, ", ", column))
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="xtabs", reset="twoWayTable", apply="twoWayTable")
radioButtons(optionsTab, name="percents",
buttons=c("rowPercents", "columnPercents", "totalPercents", "nonePercents"),
values=c("row", "column", "total", "none"), initialValue=dialog.values$initial.percents,
labels=gettextRcmdr(c("Row percentages", "Column percentages", "Percentages of total", "No percentages")),
title=gettextRcmdr("Compute Percentages"),
columns=2)
checkBoxes(optionsTab, frame="testsFrame", boxes=c("chisqTest", "chisqComponents", "expFreq", "fisherTest"),
initialValues=c(dialog.values$initial.chisq, dialog.values$initial.chisqComp,
dialog.values$initial.expected, dialog.values$initial.fisher),
labels=gettextRcmdr(c("Chi-square test of independence", "Components of chi-square statistic",
"Print expected frequencies", "Fisher's exact test")),
columns=2)
tkgrid(getFrame(rowBox), labelRcmdr(variablesFrame, text=" "), getFrame(columnBox), sticky="nw")
tkgrid(variablesFrame, sticky="w")
tkgrid(percentsFrame, sticky="nw")
tkgrid(labelRcmdr(optionsTab, text=gettextRcmdr("Hypothesis Tests"), fg=getRcmdr("title.color"), font="RcmdrTitleFont"), sticky="w")
tkgrid(testsFrame, sticky="nw")
tkgrid(subsetFrame, sticky="w")
dialogSuffix(use.tabs=TRUE, grid.buttons=TRUE, tab.names=c("Data", "Statistics"))
}
multiWayTable <- function (){
Library("abind")
defaults <- list (initial.row = NULL, initial.column = NULL, initial.control = NULL,
initial.percents = "none", initial.subset=gettextRcmdr("<all valid cases>"))
dialog.values <- getDialog ("multiWayTable", defaults)
initializeDialog(title = gettextRcmdr("Multi-Way Table"))
variablesFrame <- tkframe(top)
.factors <- Factors()
rowBox <- variableListBox(variablesFrame, .factors, title = gettextRcmdr("Row variable (pick one)"),
initialSelection = varPosn (dialog.values$initial.row, "factor"))
columnBox <- variableListBox(variablesFrame, .factors, title = gettextRcmdr("Column variable (pick one)"),
initialSelection = varPosn (dialog.values$initial.column, "factor"))
controlBox <- variableListBox(variablesFrame, .factors, selectmode = "multiple",
title = gettextRcmdr("Control variable(s) (pick one or more)"),
initialSelection = varPosn (dialog.values$initial.control, "factor"))
subsetBox(subset.expression = dialog.values$initial.subset)
onOK <- function() {
row <- getSelection(rowBox)
column <- getSelection(columnBox)
controls <- getSelection(controlBox)
if (length(row) == 0 || length(column) == 0 || length(controls) ==
0) {
errorCondition(recall = multiWayTable, message = gettextRcmdr("You must select row, column, and control variables"))
return()
}
if ((row == column) || is.element(row, controls) || is.element(column,
controls)) {
errorCondition(recall = multiWayTable, message = gettextRcmdr("Row, column, and control variables must be different."))
return()
}
percents <- as.character(tclvalue(percentsVariable))
initial.subset <- subset <- tclvalue(subsetVariable)
subset <- if (trim.blanks(subset) == gettextRcmdr("<all valid cases>"))
""
else paste(", subset=", subset, sep = "")
putDialog ("multiWayTable", list (initial.row = row, initial.column = column, initial.control = controls, initial.percents = percents, initial.subset=initial.subset))
closeDialog()
command <- paste("local({\n .Table <- xtabs(~", row, "+", column, "+", paste(controls,
collapse = "+"), ", data=", ActiveDataSet(), subset,
')\n cat("\\nFrequency table:\\n")\n print(.Table)', sep = "")
if (percents == "row")
command <- paste(command, '\n cat("\\nRow percentages:\\n")\n print(rowPercents(.Table))', sep="")
if (percents == "column")
command <- paste(command, '\n cat("\\nColumn percentages:\\n")\n print(colPercents(.Table))', sep="")
command <- paste(command, "\n})")
doItAndPrint(command)
insertRmdSection(paste0(gettextRmdHeader("Multi-Way Contingency Table: "), row, ", ", column,
", ", paste(controls, collapse=", ")))
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject = "xtabs", reset = "multiWayTable", apply = "multiWayTable")
radioButtons(name = "percents", buttons = c("rowPercents",
"columnPercents", "nonePercents"), values = c("row",
"column", "none"), labels = gettextRcmdr(c("Row percentages",
"Column percentages", "No percentages")), title = gettextRcmdr("Compute Percentages"),
initialValue = dialog.values$initial.percents)
tkgrid(getFrame(rowBox), labelRcmdr(variablesFrame, text = " "),
getFrame(columnBox), labelRcmdr(variablesFrame, text = " "),
getFrame(controlBox), sticky = "nw")
tkgrid(variablesFrame, sticky = "w")
tkgrid(percentsFrame, sticky = "w")
tkgrid(subsetFrame, sticky = "w")
tkgrid(buttonsFrame, sticky = "ew")
dialogSuffix()
}
enterTable <- function(){
Library("abind")
env <- environment()
defaults <- list(initial.tab=0, initial.rowname="", initial.colname="")
dialog.values <- getDialog("enterTable", defaults)
initializeDialog(title=gettextRcmdr("Enter Two-Way Table"), use.tabs=TRUE, tabs=c("tableTab", "statisticsTab"))
assign(".tableFrame", tkframe(tableTab), envir=env)
setUpTable <- function(...){
tkdestroy(get(".tableFrame", envir=env))
assign(".tableFrame", tkframe(tableTab), 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, if (is.null(initial.table) || j > length(colnames)) tclVar(j) else tclVar(colnames[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, if (is.null(initial.table) || i > length(rownames)) tclVar("") else tclVar(initial.table[i, 1]) , envir=env)
row.varname <- paste(".rowname.", i, sep="")
assign(row.varname, if (is.null(initial.table) || i > length(rownames)) tclVar(i) else tclVar(rownames[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, if (is.null(initial.table) || i > length(rownames) || j > length(colnames))
tclVar("") else tclVar(initial.table[i, j]), 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="ew", padx = 6)
}
initial.table <- getRcmdr("savedTable")
initial.percentages <- if (is.null(initial.table)) "none" else attr(initial.table, "percentages")
initial.tests <- if (is.null(initial.table)) c("1", "0", "0", "0") else attr(initial.table, "tests")
if (is.null(initial.table)){
rowsValue <- tclVar("2")
colsValue <- tclVar("2")
}
else {
rowsValue <- tclVar(nrow(initial.table))
colsValue <- tclVar(ncol(initial.table))
rownames <- rownames(initial.table)
colnames <- colnames(initial.table)
}
sliderFrame <- tkframe(tableTab)
rowsSlider <- tkscale(sliderFrame, from=2, to=10, showvalue=FALSE, variable=rowsValue,
resolution=1, orient="horizontal", command=setUpTable)
rowsShow <- labelRcmdr(sliderFrame, textvariable=rowsValue, width=2, justify="right")
colsSlider <- tkscale(sliderFrame, from=2, to=10, showvalue=FALSE, variable=colsValue,
resolution=1, orient="horizontal", command=setUpTable)
colsShow <- labelRcmdr(sliderFrame, textvariable=colsValue, width=2, justify="right")
variableNamesFrame <- tkframe(tableTab)
rowVariableName <- tclVar(dialog.values$initial.rowname)
rowVariableBox <-ttkentry(variableNamesFrame, width="20", textvariable=rowVariableName)
colVariableName <- tclVar(dialog.values$initial.colname)
colVariableBox <-ttkentry(variableNamesFrame, width="20", textvariable=colVariableName)
onOK <- function(){
tab <- if (as.character(tkselect(notebook)) == tableTab$ID) 0 else 1
rowvar <- tclvalue(rowVariableName)
colvar <- tclvalue(colVariableName)
putDialog("enterTable", list(initial.tab=tab, initial.rowname=rowvar, initial.colname=colvar))
if (rowvar == "") rowvar <- "rows"
if (colvar == "") colvar <- "columns"
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=enterTable, 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=enterTable, message=gettextRcmdr("Row names are not unique."))
return()
}
if (length(unique(col.names)) != ncols){
errorCondition(recall=enterTable, 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="")
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=""))
command <- paste0('dimnames(.Table) <- list("', rowvar, '"=c(', paste(paste0('"', row.names, '"'), collapse=", "),
'), "', colvar, '"=c(', paste(paste0('"', col.names, '"'), collapse=", "), '))')
doItAndPrint(command)
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)"
doItAndPrint(paste(".Test <- ", command, sep=""))
doItAndPrint(".Test")
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)
}
logger("remove(.Test)")
remove(.Test, envir=.GlobalEnv)
}
if (fisher == 1) doItAndPrint("fisher.test(.Table)")
if (getRcmdr("retain.selections")){
attr(.Table, "percentages") <- percents
attr(.Table, "tests") <- c(chisq, chisqComp, expected, fisher)
putRcmdr("savedTable", .Table)
}
logger("remove(.Table)")
insertRmdSection(paste0(gettextRmdHeader("Two-Way Contingency Table: "), rowvar, ", ", colvar))
remove(.Table, envir=.GlobalEnv)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="chisq.test", reset="resetEnterTable", apply = "enterTable")
radioButtons(statisticsTab, name="percents", buttons=c("rowPercents", "columnPercents", "totalPercents", "nonePercents"), values=c("row", "column", "total", "none"),
initialValue=initial.percentages, labels=gettextRcmdr(c("Row percentages", "Column percentages", "Percentages of total", "No percentages")), title=gettextRcmdr("Compute Percentages"),
columns=2)
checkBoxes(statisticsTab, frame="testsFrame", boxes=c("chisq", "chisqComponents", "expFreq", "fisher"), initialValues=initial.tests,
labels=gettextRcmdr(c("Chi-square test of independence", "Components of chi-square statistic",
"Print expected frequencies", "Fisher's exact test")), title=gettextRcmdr("Hypothesis Test"),
columns=2)
tkgrid(labelRcmdr(variableNamesFrame, text=gettextRcmdr("Name for Row Variable (optional): ")), rowVariableBox, sticky="w")
tkgrid(labelRcmdr(variableNamesFrame, text=""))
tkgrid(labelRcmdr(variableNamesFrame, text=gettextRcmdr("Name for Column Variable (optional): ")), colVariableBox, sticky="w")
tkgrid(variableNamesFrame, sticky="w")
tkgrid(labelRcmdr(sliderFrame, text=gettextRcmdr("Number of Rows:")), rowsSlider, rowsShow, sticky="we", padx = 6, pady = 6)
tkgrid(labelRcmdr(sliderFrame, text=gettextRcmdr("Number of Columns:")), colsSlider, colsShow, sticky="we", padx = 6, pady = 6)
tkgrid(sliderFrame, sticky="w")
tkgrid(labelRcmdr(tableTab, text=gettextRcmdr("Enter counts:"), fg=getRcmdr("title.color"), font="RcmdrTitleFont"), sticky="we", padx = 6, pady = 6)
tkgrid(percentsFrame, sticky="nwe", padx = 6, pady = 6)
tkgrid(testsFrame, sticky="nwe", padx = 6, pady = 6)
dialogSuffix(use.tabs=TRUE, grid.buttons=TRUE, tabs=c("tableTab", "statisticsTab"), tab.names=c("Table", "Statistics"))
#if (!WindowsP()) setUpTable()
setUpTable()
}
resetEnterTable <- function(){
putRcmdr("savedTable", NULL)
putDialog("enterTable", NULL)
enterTable()
}
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.