Nothing
R/CrossTable.R
In descr: Descriptive Statistics
Defines functions
dim.CrossTable
as.data.frame.CrossTable
print.CrossTable
Abbrev1
CreateNewTab
GetDigitsList
# These functions were developed from the function CrossTable of the package
# gmodels. The original function had the following comments:
#
# Revision 2.2 2006/05/02
# Fix a bug when a matrix is passed as the 'x' argument
# Reported by Prof. Albert Sorribas same day
# Fix involved creating default values for RowData and ColData
# when there are no dimnames for the matrix
# Revision 2.1 2005/06/26
# Added 'dnn' argument to enable specification of dimnames
# as per table()
# Correct bug in SPSS output for 1d table, where proportions
# were being printed and not percentages ('%' output)
# Revision 2.0 2005/04/27
# Added 'format = "d"' to all table count output
# so that large integers do not print in
# scientific notation
GetDigitsList <- function(x)
{
if(is.list(x$digits))
dgts <- list(expected = ifelse(is.null(x$digits$expected), 1, x$digits$expected),
prop = ifelse(is.null(x$digits$prop), 1, x$digits$prop),
percent = ifelse(is.null(x$digits$percent), 1, x$digits$percent),
others = ifelse(is.null(x$digits$others), 1, x$digits$others))
else
dgts <- list(expected = x$digits[1], prop = x$digits[1],
percent = x$digits[1], others = x$digits[1])
dgts
}
CreateNewTab <- function(x, ...)
{
nr <- dim(x$tab)[1]
nc <- dim(x$tab)[2]
nt <- cbind(x$tab, x$rs)
colnames(nt)[ncol(nt)] <- gettext("Total", domain = "R-descr")
nt <- format(nt, scientific = FALSE)
dgts <- GetDigitsList(x)
if(x$format == "SPSS"){
hdd <- 100
dgts$prop <- dgts$percent
} else {
hdd <- 1
x$percent <- FALSE
}
appendlines <- function(nt, xx, rowlab, prct = FALSE, hasttl = FALSE)
{
if(prct)
for(i in 1:nrow(xx))
for(j in 1:ncol(xx))
xx[i, j] <- paste0(xx[i, j], "%")
if(!hasttl)
xx <- cbind(xx, rep("", nr))
if(!x$row.labels)
rowlab <- " "
rownames(xx) <- rep(rowlab, nrow(xx))
n <- dim(nt)[1] / nr
nt <- rbind(nt, xx)
idx <- integer()
k <- 1
l <- nr * n + 1
for(i in 1:nr){
for(j in 1:n){
idx <- c(idx, k)
k <- k + 1
}
idx <- c(idx, l)
l <- l + 1
}
nt <- nt[idx, ]
nt
}
if(x$expected){
xx <- x$CST$expected
xx <- format(round(xx, dgts$expected), scientific = FALSE, trim = TRUE, ...)
nt <- appendlines(nt, xx, gettext("expected", domain = "R-descr"))
}
if(x$prop.chisq){
xx <- ((x$CST$expected - x$tab) ^ 2) / x$CST$expected
xx <- format(round(xx, digits = dgts$others), trim = TRUE, ...)
nt <- appendlines(nt, xx, gettext("chisq", domain = "R-descr"))
}
if(!is.na(x$prop.row[1])){
xx <- cbind(x$prop.row, x$rs / x$gt)
xx <- format(round(xx * hdd, digits = dgts$prop), trim = TRUE, ...)
if(hdd == 100)
nt <- appendlines(nt, xx, gettext("row %", domain = "R-descr"),
x$percent, TRUE)
else
nt <- appendlines(nt, xx, gettext("row prop.", domain = "R-descr"),
x$percent, TRUE)
}
if(!is.na(x$prop.col[1])){
xx <- format(round(x$prop.col * hdd, digits = dgts$prop), trim = TRUE, ...)
if(hdd == 100)
nt <- appendlines(nt, xx, gettext("col %", domain = "R-descr"),
x$percent)
else
nt <- appendlines(nt, xx, gettext("col prop.", domain = "R-descr"),
x$percent)
}
if(!is.na(x$prop.tbl[1])){
xx <- format(round(x$prop.tbl * hdd, digits = dgts$prop), trim = TRUE, ...)
if(hdd == 100)
nt <- appendlines(nt, xx, gettext("table %", domain = "R-descr"),
x$percent)
else
nt <- appendlines(nt, xx, gettext("table prop.", domain = "R-descr"),
x$percent)
}
if(!is.na(x$resid) && x$resid == TRUE){
xx <- x$tab - x$CST$expected
xx <- format(round(xx, digits = dgts$others), scientific = FALSE, trim = TRUE, ...)
nt <- appendlines(nt, xx, gettext("residual", domain = "R-descr"))
}
if(!is.na(x$sresid) && x$sresid == TRUE){
xx <- x$CST$residual
xx <- format(round(xx, digits = dgts$others), trim = TRUE, ...)
nt <- appendlines(nt, xx, gettext("std. res.", domain = "R-descr"))
}
if(!is.na(x$asr[1])){
xx <- format(round(x$asr, digits = dgts$others), trim = TRUE, ...)
nt <- appendlines(nt, xx, gettext("adj. std. res.", domain = "R-descr"))
}
if(x$total.c){
nt <- rbind(nt, format(c(x$cs, x$gt), scientific = FALSE))
rownames(nt)[nrow(nt)] <- gettext("Total", domain = "R-descr")
# Add final row if necessary
if(!is.na(x$prop.col[1])){
xx <- format(round(hdd * x$cs / x$gt, digits = dgts$prop), trim = TRUE, ...)
if(hdd == 100 && x$percent)
xx <- paste0(xx, "%")
nt <- rbind(nt, c(xx, ""))
}
}
# Delete last column if necessary
if(!x$total.r)
nt <- nt[, 1:(ncol(nt)-1)]
tdim <- dim(nt)
tdnn <- list(rownames(nt), colnames(nt))
names(tdnn) <- c(attr(nt, "RowData"), attr(nt, "ColData"))
attributes(nt) <- NULL
attr(nt, "dim") <- tdim
dimnames(nt) <- tdnn
nt
}
Abbrev1 <- function(x, lmt)
{
if(nchar(x) <= lmt)
return(x)
xc <- charToRaw(x)
len1 <- length(xc)
# Two consecutive spaces
i <- 1
while(i < len1){
if(xc[i] == 0x20 && xc[i+1] == 0x20)
return(rawToChar(xc[-i]))
i <- i + 1
}
# Trailing space or tab
if(xc[len1] == 0x20 || xc[len1] == 0x09)
return(rawToChar(xc[-len1]))
# Last lower case ascii vowel (unless it is the first letter in a word)
i <- len1
while(i > 1){
if(xc[i-1] != 0x20 && (xc[i] == 0x61 || xc[i] == 0x65 || xc[i] == 0x69 || xc[i] == 0x6f || xc[i] == 0x75)){
xc <- xc[-i]
return(rawToChar(xc))
}
i <- i - 1
}
# Last lower case ascii letter (unless it is the first letter in a word)
i <- len1
while(i > 0){
if(xc[i-1] != 0x20 && xc[i] > 0x60 && xc[i] < 0x7b){
xc <- xc[-i]
return(rawToChar(xc))
}
i <- i - 1
}
# Last letter
x <- unlist(strsplit(x, ""))
len <- length(x)
x <- x[-len]
paste0(x, collapse = "")
}
CrossTable <- function (x, y,
digits = list(expected = 1, prop = 3, percent = 1, others = 3),
max.width = NA, expected = FALSE,
prop.r = TRUE, prop.c = TRUE, prop.t = TRUE, prop.chisq = TRUE,
chisq = FALSE, fisher = FALSE, mcnemar = FALSE, resid = FALSE,
sresid = FALSE, asresid = FALSE, missing.include = FALSE,
drop.levels = TRUE, format = c("SAS", "SPSS"), dnn = NULL,
cell.layout = TRUE, row.labels = !cell.layout,
percent = (format == "SPSS" && !row.labels),
total.r, total.c, xlab = NULL, ylab = NULL, ...)
{
format = match.arg(format)
RowData <- deparse(substitute(x))
if (missing(y))
ColData <- NA
else
ColData <- deparse(substitute(y))
## Ensure that max.width >= 1
if (!is.na(max.width) && max.width < 1)
stop("max.width must be >= 1")
## Set 'x' vector flag
vector.x <- FALSE
if (missing(y))
{
## is x a vector?
if (is.null(dim(x)))
{
if (missing.include)
x <- no.drop.levels(x)
if (drop.levels)
x <- factor(x)
tab <- t(as.matrix(table(x)))
vector.x <- TRUE
}
## is x a matrix?
else if (length(dim(x) == 2))
{
if(any(x < 0) || any(is.na(x)))
stop("all entries of x must be nonnegative and finite")
## Check to see if x has names(dimnames) defined. If yes, use these for
## 'RowData' and 'ColData' labels, else create blank ones
## This can be overridden by setting 'dnn' values
if (is.null(names(dimnames(x))))
{
RowData <- ""
ColData <- ""
} else {
RowData <- names(dimnames(x))[1]
ColData <- names(dimnames(x))[2]
}
## Add generic column and rownames if required
## check each separately, in case user has defined one or the other
if (is.null(rownames(x)))
rownames(x) <- paste("[", 1:nrow(x), ",]", sep = "")
if (is.null(colnames(x)))
colnames(x) <- paste("[,", 1:ncol(x), "]", sep = "")
tab <- x
}
else
stop("x must be either a vector or a 2 dimensional matrix, if y is not given")
} else {
if(missing.include){
x <- no.drop.levels(x)
y <- no.drop.levels(y)
}
if(drop.levels){
x <- factor(x)
y <- factor(y)
}
if(length(x) != length(y))
stop("x and y must have the same length")
## Generate table
tab <- table(x, y)
}
## Check dnn, and use it
if(!is.null(dnn)){
if(all(dim(tab) >= 2) && length(dnn) != 2)
stop("dnn must have length of 2, one element for each table dimension")
RowData <- dnn[1]
if(length(dnn) > 1)
ColData <- dnn[2]
}
## if tab is not at least a 2 x 2, do not do stats
## even if any set to TRUE. Do not do col/table props
if (any(dim(tab) < 2))
prop.c <- prop.chisq <- chisq <- expected <- fisher <- mcnemar <- FALSE
if (vector.x && dim(tab)[2] < 2)
prop.r <- FALSE
if (!vector.x && dim(tab)[1] < 2)
prop.r <- FALSE
CPR <- CPC <- CPT <- GT <- RS <- TotalN <- CSTc <- CST <- ASR <- FTt <-
FTl <- FTg <- McN <- McNc <- NA
## Generate cell proportion of row
if(prop.r)
CPR <- prop.table(tab, 1)
## Generate cell proportion of col
if(prop.c)
CPC <- prop.table(tab, 2)
## Generate cell proportion of total
if(prop.t)
CPT <- prop.table(tab)
## Generate summary counts
GT <- sum(tab)
RS <- rowSums(tab)
CS <- colSums(tab)
if (length(dim(x) == 2))
TotalN <- GT
else
TotalN <- length(x)
## Perform Chi-Square Tests
if (expected || chisq || prop.chisq || resid || sresid || asresid) {
if(!chisq && !prop.chisq){
wv <- getOption("warn")
options(warn = -1)
}
CST <- chisq.test(tab, correct = FALSE, ...)
if (all(dim(tab) == 2))
CSTc <- chisq.test(tab, correct = TRUE, ...)
if(!chisq && !prop.chisq){
options(warn = wv)
}
}
if (asresid & !vector.x)
ASR <- (CST$observed-CST$expected)/sqrt(CST$expected*((1-RS/GT) %*% t(1-CS/GT)))
if (fisher)
{
try(FTt <- fisher.test(tab, alternative = "two.sided"))
if (all(dim(tab) == 2))
{
FTl <- fisher.test(tab, alternative = "less")
FTg <- fisher.test(tab, alternative = "greater")
}
}
if (mcnemar)
{
if(dim(tab)[1] == dim(tab)[2])
McN <- mcnemar.test(tab, correct = FALSE)
if (all(dim(tab) == 2))
McNc <- mcnemar.test(tab, correct = TRUE)
}
if(!missing(total.r)){
if(!is.logical(total.r))
stop(gettext("total.r must be logical", domain = "R-descr"))
if(missing(total.c))
total.c <- total.r
}
if(!missing(total.c)){
if(!is.logical(total.c))
stop(gettext("total.c must be logical", domain = "R-descr"))
if(missing(total.r))
total.r <- total.c
}
if(missing(total.r) & missing(total.c))
total.r <- total.c <- TRUE
res <- list(tab = tab, prop.row = CPR, prop.col = CPC, prop.tbl = CPT,
gt = GT, rs = RS, cs = CS, total.n = TotalN, chisq = chisq,
CST = CST, chisq.corr = CSTc, fisher.ts = FTt,
fisher.lt = FTl, fisher.gt = FTg, print.mcnemar = mcnemar,
mcnemar = McN, mcnemar.corr = McNc, asr = ASR,
RowData = RowData, ColData = ColData, digits = digits,
max.width = max.width, vector.x = vector.x,
expected = expected, prop.chisq = prop.chisq, resid = resid,
sresid = sresid, asresid = asresid, format = format,
cell.layout = cell.layout, row.labels = row.labels,
percent = percent, total.r = total.r, total.c = total.c)
# Add "t" element to avoid breaking pander package which manipulates the
# CrossTable object:
res$t <- res$tab
# Attributes for plotting
attr(res, "xlab") <- xlab
attr(res, "ylab") <- ylab
class(res) <- "CrossTable"
res
}
print.CrossTable <- function(x, ...)
{
argl <- list(...)
for(n in names(argl))
if(n %in% names(x))
x[[n]] <- argl[[n]]
nt <- CreateNewTab(x, ...)
tab <- x$tab
CPR <- x$prop.row
CPC <- x$prop.col
CPT <- x$prop.tbl
GT <- x$gt
RS <- x$rs
CS <- x$cs
TotalN <- x$total.n
chisq <- x$chisq
CST <- x$CST
CSTc <- x$chisq.corr
FTt <- x$fisher.ts
FTl <- x$fisher.lt
FTg <- x$fisher.gt
McN <- x$mcnemar
McNc <- x$mcnemar.corr
ASR <- x$asr
RowData <- x$RowData
ColData <- x$ColData
max.width <- x$max.width
vector.x <- x$vector.x
expected <- x$expected
prop.r <- !is.na(CPR[1])
prop.c <- !is.na(CPC[1])
prop.t <- !is.na(CPT[1])
prop.chisq <- x$prop.chisq
fisher <- (class(FTt) == "htest")
resid <- x$resid
sresid <- x$sresid
asresid <- x$asresid
mcnemar <- x$print.mcnemar
format <- x$format
cell.layout <- x$cell.layout
total.r <- x$total.r
total.c <- x$total.c
outDec <- getOption("OutDec")
dgts <- GetDigitsList(x)
if(format == "SAS") {
hdd <- 1
} else {
if (format == "SPSS") {
hdd <- 100
dgts$prop <- dgts$percent
} else {
stop("unknown format")
}
}
if(vector.x)
expected <- prop.chisq <- prop.c <- prop.t <- resid <- sresid <- asresid <- FALSE
#### Printing the tables
## Print Cell Layout
if(cell.layout){
cat(" ", gettext("Cell Contents", domain = "R-descr"), "\n")
cat("|-------------------------|\n")
if (format=="SAS") {
cat(gettext("| N |", domain = "R-descr"), "\n")
if (expected)
cat(gettext("| Expected N |", domain = "R-descr"), "\n")
if (prop.chisq)
cat(gettext("| Chi-square contribution |", domain = "R-descr"), "\n")
if (prop.r)
cat(gettext("| N / Row Total |", domain = "R-descr"), "\n")
if (prop.c)
cat(gettext("| N / Col Total |", domain = "R-descr"), "\n")
if (prop.t)
cat(gettext("| N / Table Total |", domain = "R-descr"), "\n")
} else if (format == "SPSS") {
cat(gettext("| Count |", domain = "R-descr"), "\n")
if (expected)
cat(gettext("| Expected Values |", domain = "R-descr"), "\n")
if (prop.chisq)
cat(gettext("| Chi-square contribution |", domain = "R-descr"), "\n")
if (prop.r)
cat(gettext("| Row Percent |", domain = "R-descr"), "\n")
if (prop.c)
cat(gettext("| Column Percent |", domain = "R-descr"), "\n")
if (prop.t)
cat(gettext("| Total Percent |", domain = "R-descr"), "\n")
}
if (resid)
cat(gettext("| Residual |", domain = "R-descr"), "\n")
if (sresid)
cat(gettext("| Std Residual |", domain = "R-descr"), "\n")
if (asresid)
cat(gettext("| Adj Std Resid |", domain = "R-descr"), "\n")
cat("|-------------------------|\n")
}
## Print 1 X N vector
if (vector.x) {
## Set consistent column widths based upon dimnames and table values
strt <- formatC(unclass(tab), digits = dgts$prop, format = "f", width = 0, decimal.mark = outDec)
CWidth <- max(dgts$prop + 2, c(nchar(strt, type = "width"),
nchar(dimnames(tab)[[2]], type = "width")))
if(prop.r){
if(vector.x)
strt <- formatC(unclass(CPT), digits = dgts$prop, format = "f", width = 0, decimal.mark = outDec)
CWidth <- max(CWidth, nchar(strt, type = "width"))
}
## Create row separators
RowSep <- paste(rep("-", CWidth + 2), collapse = "")
if(is.na(max.width))
max.width = floor((getOption("width") - 2) / (CWidth + 3))
if (length(tab) > max.width) {
## set breakpoints for output based upon max.width
final.row <- length(tab) %% max.width
max <- length(tab) - final.row
## Define breakpoint indices for each row
start <- seq(1, max, max.width)
end <- start + (max.width - 1)
## Add final.row if required
if (final.row > 0) {
start <- c(start, end[length(end)] + 1)
end <- c(end, end[length(end)] + final.row)
}
} else {
## Each value printed horizontally in a single row
start <- 1
end <- length(tab)
}
cat("\n")
for (i in 1:length(start)) {
cat("| ")
cat(paste(formatC(dimnames(tab)[[2]][start[i]:end[i]], width = CWidth, format = "s"), collapse = " | "))
cat(" |\n|")
cat(rep(RowSep, (end[i] - start[i]) + 1), sep = "|")
cat("|\n| ")
cat(formatC(tab[, start[i]:end[i]], width = CWidth, format = "d"), sep = " | ")
if(prop.r){
cat(" |\n| ")
cat(formatC(CPT[, start[i]:end[i]] * hdd, width = CWidth,
digits = dgts$prop, format = "f", decimal.mark = outDec), sep = " | ")
}
cat(" |\n|")
cat(rep(RowSep, (end[i] - start[i]) + 1), sep = "|")
cat("|\n\n")
} ## End of for (i in 1:length(start))
if(format == "SPSS" && GT < TotalN)
cat("\n", gettext("Number of Missing Observations:", domain = "R-descr"),
" ", TotalN-GT, " (", 100*(TotalN-GT)/TotalN, "%)\n", sep = "")
return(invisible(x))
} ## End of if (vector.x)
nr <- nrow(nt)
nc <- ncol(nt)
rnames <- rownames(nt)
cnames <- colnames(nt)
# Check column widths and fix them if necessary
availablewidth <- getOption("width")
minColWd <- max(nchar(nt, type = "width"))
clabwidth <- nchar(cnames, type = "width")
rlabwidth <- max(nchar(rnames, type = "width"), nchar(RowData, type = "width")) + 1
totalwidth <- rlabwidth + (sum(clabwidth + 3))
# Abbreviate row and column labels. Withdraw one char of the newlimit
# label until the rows fit in the screen
while(totalwidth > availablewidth){
newlimit <- max(c(rlabwidth - 1, clabwidth)) - 1
# FIXME: The algorithm should consider the minColWd of each column
if(newlimit < minColWd)
break
rnames <- sapply(rnames, Abbrev1, newlimit)
cnames <- sapply(cnames, Abbrev1, newlimit)
RowData <- Abbrev1(RowData, newlimit)
clabwidth <- nchar(cnames, type = "width")
clabwidth[clabwidth < minColWd] <- minColWd
rlabwidth <- max(nchar(rnames, type = "width"), nchar(RowData, type = "width")) + 1
totalwidth <- rlabwidth + (sum(clabwidth + 3))
}
minColWd <- apply(nt, 2, function(x) max(nchar(x, type = "width")))
clabwidth <- apply(cbind(clabwidth, minColWd), 1, max)
dashedline <- rep("-", sum(clabwidth) + 3 * nc + rlabwidth)
ddashedline <- gsub("-", "=", dashedline)
# Calculate horizontal line locations
if(x$total.c && !is.na(x$prop.col)[1])
nrnt <- nrow(nt) - 2
else if(x$total.c)
nrnt <- nrow(nt) - 1
else
nrnt <- nrow(nt)
n <- nrnt / nrow(tab)
idxh <- seq(n+1, nrnt+1, n)
# idxh <- idxh[idxh < nrow(nt)] # necessary when total.c = FALSE
## Print table cells
cat("\n", ddashedline, "\n", sep = "")
if(ColData != "")
cat(formatC(" ", width = rlabwidth), " ", ColData, "\n", sep = "", collapse = "")
if(RowData == "")
cat(formatC(" ", width = rlabwidth))
else
cat(formatC(RowData, width = rlabwidth, format = "s", flag = "-"))
for(j in 1:nc)
cat(" ", formatC(cnames[j], width = clabwidth[j]))
cat("\n", dashedline, "\n", sep = "")
for(i in 1:nr){
if(i %in% idxh)
cat(dashedline, "\n", sep = "")
cat(formatC(rnames[i], width = rlabwidth, format = "s", flag = "-"), sep = "")
if(x$percent && (prop.r || prop.c || prop.t)){
for(j in 1:nc)
if(grepl("%", nt[i, j]))
cat(" ", formatC(nt[i, j], width = clabwidth[j]), sep = "")
else
cat(" ", formatC(nt[i, j], width = clabwidth[j]), " ", sep = "")
} else {
for(j in 1:nc)
cat(" ", formatC(nt[i, j], width = clabwidth[j]))
}
cat("\n")
}
cat(ddashedline, "\n", sep = "")
## Print Statistics
if (chisq)
{
cat("\n")
cat(gettext("Statistics for All Table Factors", domain = "R-descr"),
"\n\n", sep="")
cat(CST$method, "\n")
cat("------------------------------------------------------------\n")
fp <- format.pval(CST$p.value, digits = dgts$others)
pv <- paste("p", if(substr(fp, 1L, 1L) == "<") fp else paste("=", fp))
cat(gettext("Chi^2 =", domain = "R-descr"), CST$statistic,
" ", gettext("d.f. =", domain = "R-descr"), CST$parameter,
" ", pv, "\n\n")
if (all(dim(tab) == 2))
{
cat(CSTc$method, "\n")
cat("------------------------------------------------------------\n")
fp <- format.pval(CSTc$p.value, digits = dgts$others)
pv <- paste("p", if(substr(fp, 1L, 1L) == "<") fp else paste("=", fp))
cat(gettext("Chi^2 =", domain = "R-descr"), CSTc$statistic,
" ", gettext("d.f. =", domain = "R-descr"), CSTc$parameter,
" ", pv, "\n")
}
}
## Print McNemar tests
if (is.na(McN[1]) == FALSE)
{
cat(rep("\n", 2))
cat(McN$method, "\n")
cat("------------------------------------------------------------\n")
fp <- format.pval(McN$p.value, digits = dgts$others)
pv <- paste("p", if(substr(fp, 1L, 1L) == "<") fp else paste("=", fp))
cat(gettext("Chi^2 =", domain = "R-descr"), McN$statistic,
" ", gettext("d.f. =", domain = "R-descr"), McN$parameter,
" ", pv, "\n\n")
if (is.na(McNc[1]) == FALSE)
{
cat(McNc$method, "\n")
cat("------------------------------------------------------------\n")
fp <- format.pval(McNc$p.value, digits = dgts$others)
pv <- paste("p", if(substr(fp, 1L, 1L) == "<") fp else paste("=", fp))
cat(gettext("Chi^2 =", domain = "R-descr"), McNc$statistic,
" ", gettext("d.f. =", domain = "R-descr"), McNc$parameter,
" ", pv, "\n")
}
}
## Pint Fisher Tests
if (fisher)
{
cat(rep("\n", 2))
cat(gettext("Fisher's Exact Test for Count Data", domain = "R-descr"))
cat("\n------------------------------------------------------------\n")
if (all(dim(tab) == 2))
{
cat(gettext("Sample estimate odds ratio:", domain = "R-descr"), FTt$estimate, "\n\n")
cat(gettext("Alternative hypothesis: true odds ratio is not equal to 1",
domain = "R-descr"), "\n")
fp <- format.pval(FTt$p.value, digits = dgts$others)
pv <- paste("p", if(substr(fp, 1L, 1L) == "<") fp else paste("=", fp))
cat(pv, "\n")
cat(gettextf("95%s confidence interval:", "%", domain = "R-descr"), FTt$conf.int, "\n\n")
cat(gettext("Alternative hypothesis: true odds ratio is less than 1",
domain = "R-descr"), "\n")
fp <- format.pval(FTl$p.value, digits = dgts$others)
pv <- paste("p", if(substr(fp, 1L, 1L) == "<") fp else paste("=", fp))
cat(pv, "\n")
cat(gettext("95%s confidence interval:", "%", domain = "R-descr"), FTl$conf.int, "\n\n")
cat(gettext("Alternative hypothesis: true odds ratio is greater than 1",
domain = "R-descr"), "\n")
fp <- format.pval(FTg$p.value, digits = dgts$others)
pv <- paste("p", if(substr(fp, 1L, 1L) == "<") fp else paste("=", fp))
cat(pv, "\n")
cat(gettext("95%s confidence interval:", "%", domain = "R-descr"), FTg$conf.int, "\n\n")
}
else
{
cat(gettext("Alternative hypothesis: two.sided", domain = "R-descr"), "\n")
fp <- format.pval(FTt$p.value, digits = dgts$others)
pv <- paste("p", if(substr(fp, 1L, 1L) == "<") fp else paste("=", fp))
cat(pv, "\n")
}
} ## End Of If(Fisher) Loop
# cat(rep("\n", 2))
if(format == "SPSS"){
if (any(dim(tab) >= 2) & any(chisq, mcnemar, fisher))
{
MinExpF = min(CST$expected)
cat(" ", gettext("Minimum expected frequency:", domain = "R-descr"), MinExpF, "\n")
NMinExpF = length(CST$expected[which(CST$expected<5)])
if (NMinExpF > 0)
{
NCells = length(CST$expected)
cat(gettext("Cells with Expected Frequency < 5:", domain = "R-descr"),
" ", NMinExpF, " ", gettext("of", domain = "R-descr"), " ",
NCells, " (", 100*NMinExpF/NCells, "%)\n", sep = "")
}
cat("\n")
} ## End of if (any(dim(tab)...))
}
return(invisible(x))
}
as.data.frame.CrossTable <- function(x, ...) as.data.frame(x$tab, ...)
# Needed by tableStyles() of odfWeave package:
dim.CrossTable <- function(x){
dim(x$tab) + 1
}
Try the descr package in your browser
Any scripts or data that you put into this service are public.
descr documentation built on Nov. 28, 2023, 1:10 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions dim.CrossTable as.data.frame.CrossTable print.CrossTable Abbrev1 CreateNewTab GetDigitsList
# These functions were developed from the function CrossTable of the package
# gmodels. The original function had the following comments:
#
# Revision 2.2 2006/05/02
# Fix a bug when a matrix is passed as the 'x' argument
# Reported by Prof. Albert Sorribas same day
# Fix involved creating default values for RowData and ColData
# when there are no dimnames for the matrix
# Revision 2.1 2005/06/26
# Added 'dnn' argument to enable specification of dimnames
# as per table()
# Correct bug in SPSS output for 1d table, where proportions
# were being printed and not percentages ('%' output)
# Revision 2.0 2005/04/27
# Added 'format = "d"' to all table count output
# so that large integers do not print in
# scientific notation
GetDigitsList <- function(x)
{
if(is.list(x$digits))
dgts <- list(expected = ifelse(is.null(x$digits$expected), 1, x$digits$expected),
prop = ifelse(is.null(x$digits$prop), 1, x$digits$prop),
percent = ifelse(is.null(x$digits$percent), 1, x$digits$percent),
others = ifelse(is.null(x$digits$others), 1, x$digits$others))
else
dgts <- list(expected = x$digits[1], prop = x$digits[1],
percent = x$digits[1], others = x$digits[1])
dgts
}
CreateNewTab <- function(x, ...)
{
nr <- dim(x$tab)[1]
nc <- dim(x$tab)[2]
nt <- cbind(x$tab, x$rs)
colnames(nt)[ncol(nt)] <- gettext("Total", domain = "R-descr")
nt <- format(nt, scientific = FALSE)
dgts <- GetDigitsList(x)
if(x$format == "SPSS"){
hdd <- 100
dgts$prop <- dgts$percent
} else {
hdd <- 1
x$percent <- FALSE
}
appendlines <- function(nt, xx, rowlab, prct = FALSE, hasttl = FALSE)
{
if(prct)
for(i in 1:nrow(xx))
for(j in 1:ncol(xx))
xx[i, j] <- paste0(xx[i, j], "%")
if(!hasttl)
xx <- cbind(xx, rep("", nr))
if(!x$row.labels)
rowlab <- " "
rownames(xx) <- rep(rowlab, nrow(xx))
n <- dim(nt)[1] / nr
nt <- rbind(nt, xx)
idx <- integer()
k <- 1
l <- nr * n + 1
for(i in 1:nr){
for(j in 1:n){
idx <- c(idx, k)
k <- k + 1
}
idx <- c(idx, l)
l <- l + 1
}
nt <- nt[idx, ]
nt
}
if(x$expected){
xx <- x$CST$expected
xx <- format(round(xx, dgts$expected), scientific = FALSE, trim = TRUE, ...)
nt <- appendlines(nt, xx, gettext("expected", domain = "R-descr"))
}
if(x$prop.chisq){
xx <- ((x$CST$expected - x$tab) ^ 2) / x$CST$expected
xx <- format(round(xx, digits = dgts$others), trim = TRUE, ...)
nt <- appendlines(nt, xx, gettext("chisq", domain = "R-descr"))
}
if(!is.na(x$prop.row[1])){
xx <- cbind(x$prop.row, x$rs / x$gt)
xx <- format(round(xx * hdd, digits = dgts$prop), trim = TRUE, ...)
if(hdd == 100)
nt <- appendlines(nt, xx, gettext("row %", domain = "R-descr"),
x$percent, TRUE)
else
nt <- appendlines(nt, xx, gettext("row prop.", domain = "R-descr"),
x$percent, TRUE)
}
if(!is.na(x$prop.col[1])){
xx <- format(round(x$prop.col * hdd, digits = dgts$prop), trim = TRUE, ...)
if(hdd == 100)
nt <- appendlines(nt, xx, gettext("col %", domain = "R-descr"),
x$percent)
else
nt <- appendlines(nt, xx, gettext("col prop.", domain = "R-descr"),
x$percent)
}
if(!is.na(x$prop.tbl[1])){
xx <- format(round(x$prop.tbl * hdd, digits = dgts$prop), trim = TRUE, ...)
if(hdd == 100)
nt <- appendlines(nt, xx, gettext("table %", domain = "R-descr"),
x$percent)
else
nt <- appendlines(nt, xx, gettext("table prop.", domain = "R-descr"),
x$percent)
}
if(!is.na(x$resid) && x$resid == TRUE){
xx <- x$tab - x$CST$expected
xx <- format(round(xx, digits = dgts$others), scientific = FALSE, trim = TRUE, ...)
nt <- appendlines(nt, xx, gettext("residual", domain = "R-descr"))
}
if(!is.na(x$sresid) && x$sresid == TRUE){
xx <- x$CST$residual
xx <- format(round(xx, digits = dgts$others), trim = TRUE, ...)
nt <- appendlines(nt, xx, gettext("std. res.", domain = "R-descr"))
}
if(!is.na(x$asr[1])){
xx <- format(round(x$asr, digits = dgts$others), trim = TRUE, ...)
nt <- appendlines(nt, xx, gettext("adj. std. res.", domain = "R-descr"))
}
if(x$total.c){
nt <- rbind(nt, format(c(x$cs, x$gt), scientific = FALSE))
rownames(nt)[nrow(nt)] <- gettext("Total", domain = "R-descr")
# Add final row if necessary
if(!is.na(x$prop.col[1])){
xx <- format(round(hdd * x$cs / x$gt, digits = dgts$prop), trim = TRUE, ...)
if(hdd == 100 && x$percent)
xx <- paste0(xx, "%")
nt <- rbind(nt, c(xx, ""))
}
}
# Delete last column if necessary
if(!x$total.r)
nt <- nt[, 1:(ncol(nt)-1)]
tdim <- dim(nt)
tdnn <- list(rownames(nt), colnames(nt))
names(tdnn) <- c(attr(nt, "RowData"), attr(nt, "ColData"))
attributes(nt) <- NULL
attr(nt, "dim") <- tdim
dimnames(nt) <- tdnn
nt
}
Abbrev1 <- function(x, lmt)
{
if(nchar(x) <= lmt)
return(x)
xc <- charToRaw(x)
len1 <- length(xc)
# Two consecutive spaces
i <- 1
while(i < len1){
if(xc[i] == 0x20 && xc[i+1] == 0x20)
return(rawToChar(xc[-i]))
i <- i + 1
}
# Trailing space or tab
if(xc[len1] == 0x20 || xc[len1] == 0x09)
return(rawToChar(xc[-len1]))
# Last lower case ascii vowel (unless it is the first letter in a word)
i <- len1
while(i > 1){
if(xc[i-1] != 0x20 && (xc[i] == 0x61 || xc[i] == 0x65 || xc[i] == 0x69 || xc[i] == 0x6f || xc[i] == 0x75)){
xc <- xc[-i]
return(rawToChar(xc))
}
i <- i - 1
}
# Last lower case ascii letter (unless it is the first letter in a word)
i <- len1
while(i > 0){
if(xc[i-1] != 0x20 && xc[i] > 0x60 && xc[i] < 0x7b){
xc <- xc[-i]
return(rawToChar(xc))
}
i <- i - 1
}
# Last letter
x <- unlist(strsplit(x, ""))
len <- length(x)
x <- x[-len]
paste0(x, collapse = "")
}
CrossTable <- function (x, y,
digits = list(expected = 1, prop = 3, percent = 1, others = 3),
max.width = NA, expected = FALSE,
prop.r = TRUE, prop.c = TRUE, prop.t = TRUE, prop.chisq = TRUE,
chisq = FALSE, fisher = FALSE, mcnemar = FALSE, resid = FALSE,
sresid = FALSE, asresid = FALSE, missing.include = FALSE,
drop.levels = TRUE, format = c("SAS", "SPSS"), dnn = NULL,
cell.layout = TRUE, row.labels = !cell.layout,
percent = (format == "SPSS" && !row.labels),
total.r, total.c, xlab = NULL, ylab = NULL, ...)
{
format = match.arg(format)
RowData <- deparse(substitute(x))
if (missing(y))
ColData <- NA
else
ColData <- deparse(substitute(y))
## Ensure that max.width >= 1
if (!is.na(max.width) && max.width < 1)
stop("max.width must be >= 1")
## Set 'x' vector flag
vector.x <- FALSE
if (missing(y))
{
## is x a vector?
if (is.null(dim(x)))
{
if (missing.include)
x <- no.drop.levels(x)
if (drop.levels)
x <- factor(x)
tab <- t(as.matrix(table(x)))
vector.x <- TRUE
}
## is x a matrix?
else if (length(dim(x) == 2))
{
if(any(x < 0) || any(is.na(x)))
stop("all entries of x must be nonnegative and finite")
## Check to see if x has names(dimnames) defined. If yes, use these for
## 'RowData' and 'ColData' labels, else create blank ones
## This can be overridden by setting 'dnn' values
if (is.null(names(dimnames(x))))
{
RowData <- ""
ColData <- ""
} else {
RowData <- names(dimnames(x))[1]
ColData <- names(dimnames(x))[2]
}
## Add generic column and rownames if required
## check each separately, in case user has defined one or the other
if (is.null(rownames(x)))
rownames(x) <- paste("[", 1:nrow(x), ",]", sep = "")
if (is.null(colnames(x)))
colnames(x) <- paste("[,", 1:ncol(x), "]", sep = "")
tab <- x
}
else
stop("x must be either a vector or a 2 dimensional matrix, if y is not given")
} else {
if(missing.include){
x <- no.drop.levels(x)
y <- no.drop.levels(y)
}
if(drop.levels){
x <- factor(x)
y <- factor(y)
}
if(length(x) != length(y))
stop("x and y must have the same length")
## Generate table
tab <- table(x, y)
}
## Check dnn, and use it
if(!is.null(dnn)){
if(all(dim(tab) >= 2) && length(dnn) != 2)
stop("dnn must have length of 2, one element for each table dimension")
RowData <- dnn[1]
if(length(dnn) > 1)
ColData <- dnn[2]
}
## if tab is not at least a 2 x 2, do not do stats
## even if any set to TRUE. Do not do col/table props
if (any(dim(tab) < 2))
prop.c <- prop.chisq <- chisq <- expected <- fisher <- mcnemar <- FALSE
if (vector.x && dim(tab)[2] < 2)
prop.r <- FALSE
if (!vector.x && dim(tab)[1] < 2)
prop.r <- FALSE
CPR <- CPC <- CPT <- GT <- RS <- TotalN <- CSTc <- CST <- ASR <- FTt <-
FTl <- FTg <- McN <- McNc <- NA
## Generate cell proportion of row
if(prop.r)
CPR <- prop.table(tab, 1)
## Generate cell proportion of col
if(prop.c)
CPC <- prop.table(tab, 2)
## Generate cell proportion of total
if(prop.t)
CPT <- prop.table(tab)
## Generate summary counts
GT <- sum(tab)
RS <- rowSums(tab)
CS <- colSums(tab)
if (length(dim(x) == 2))
TotalN <- GT
else
TotalN <- length(x)
## Perform Chi-Square Tests
if (expected || chisq || prop.chisq || resid || sresid || asresid) {
if(!chisq && !prop.chisq){
wv <- getOption("warn")
options(warn = -1)
}
CST <- chisq.test(tab, correct = FALSE, ...)
if (all(dim(tab) == 2))
CSTc <- chisq.test(tab, correct = TRUE, ...)
if(!chisq && !prop.chisq){
options(warn = wv)
}
}
if (asresid & !vector.x)
ASR <- (CST$observed-CST$expected)/sqrt(CST$expected*((1-RS/GT) %*% t(1-CS/GT)))
if (fisher)
{
try(FTt <- fisher.test(tab, alternative = "two.sided"))
if (all(dim(tab) == 2))
{
FTl <- fisher.test(tab, alternative = "less")
FTg <- fisher.test(tab, alternative = "greater")
}
}
if (mcnemar)
{
if(dim(tab)[1] == dim(tab)[2])
McN <- mcnemar.test(tab, correct = FALSE)
if (all(dim(tab) == 2))
McNc <- mcnemar.test(tab, correct = TRUE)
}
if(!missing(total.r)){
if(!is.logical(total.r))
stop(gettext("total.r must be logical", domain = "R-descr"))
if(missing(total.c))
total.c <- total.r
}
if(!missing(total.c)){
if(!is.logical(total.c))
stop(gettext("total.c must be logical", domain = "R-descr"))
if(missing(total.r))
total.r <- total.c
}
if(missing(total.r) & missing(total.c))
total.r <- total.c <- TRUE
res <- list(tab = tab, prop.row = CPR, prop.col = CPC, prop.tbl = CPT,
gt = GT, rs = RS, cs = CS, total.n = TotalN, chisq = chisq,
CST = CST, chisq.corr = CSTc, fisher.ts = FTt,
fisher.lt = FTl, fisher.gt = FTg, print.mcnemar = mcnemar,
mcnemar = McN, mcnemar.corr = McNc, asr = ASR,
RowData = RowData, ColData = ColData, digits = digits,
max.width = max.width, vector.x = vector.x,
expected = expected, prop.chisq = prop.chisq, resid = resid,
sresid = sresid, asresid = asresid, format = format,
cell.layout = cell.layout, row.labels = row.labels,
percent = percent, total.r = total.r, total.c = total.c)
# Add "t" element to avoid breaking pander package which manipulates the
# CrossTable object:
res$t <- res$tab
# Attributes for plotting
attr(res, "xlab") <- xlab
attr(res, "ylab") <- ylab
class(res) <- "CrossTable"
res
}
print.CrossTable <- function(x, ...)
{
argl <- list(...)
for(n in names(argl))
if(n %in% names(x))
x[[n]] <- argl[[n]]
nt <- CreateNewTab(x, ...)
tab <- x$tab
CPR <- x$prop.row
CPC <- x$prop.col
CPT <- x$prop.tbl
GT <- x$gt
RS <- x$rs
CS <- x$cs
TotalN <- x$total.n
chisq <- x$chisq
CST <- x$CST
CSTc <- x$chisq.corr
FTt <- x$fisher.ts
FTl <- x$fisher.lt
FTg <- x$fisher.gt
McN <- x$mcnemar
McNc <- x$mcnemar.corr
ASR <- x$asr
RowData <- x$RowData
ColData <- x$ColData
max.width <- x$max.width
vector.x <- x$vector.x
expected <- x$expected
prop.r <- !is.na(CPR[1])
prop.c <- !is.na(CPC[1])
prop.t <- !is.na(CPT[1])
prop.chisq <- x$prop.chisq
fisher <- (class(FTt) == "htest")
resid <- x$resid
sresid <- x$sresid
asresid <- x$asresid
mcnemar <- x$print.mcnemar
format <- x$format
cell.layout <- x$cell.layout
total.r <- x$total.r
total.c <- x$total.c
outDec <- getOption("OutDec")
dgts <- GetDigitsList(x)
if(format == "SAS") {
hdd <- 1
} else {
if (format == "SPSS") {
hdd <- 100
dgts$prop <- dgts$percent
} else {
stop("unknown format")
}
}
if(vector.x)
expected <- prop.chisq <- prop.c <- prop.t <- resid <- sresid <- asresid <- FALSE
#### Printing the tables
## Print Cell Layout
if(cell.layout){
cat(" ", gettext("Cell Contents", domain = "R-descr"), "\n")
cat("|-------------------------|\n")
if (format=="SAS") {
cat(gettext("| N |", domain = "R-descr"), "\n")
if (expected)
cat(gettext("| Expected N |", domain = "R-descr"), "\n")
if (prop.chisq)
cat(gettext("| Chi-square contribution |", domain = "R-descr"), "\n")
if (prop.r)
cat(gettext("| N / Row Total |", domain = "R-descr"), "\n")
if (prop.c)
cat(gettext("| N / Col Total |", domain = "R-descr"), "\n")
if (prop.t)
cat(gettext("| N / Table Total |", domain = "R-descr"), "\n")
} else if (format == "SPSS") {
cat(gettext("| Count |", domain = "R-descr"), "\n")
if (expected)
cat(gettext("| Expected Values |", domain = "R-descr"), "\n")
if (prop.chisq)
cat(gettext("| Chi-square contribution |", domain = "R-descr"), "\n")
if (prop.r)
cat(gettext("| Row Percent |", domain = "R-descr"), "\n")
if (prop.c)
cat(gettext("| Column Percent |", domain = "R-descr"), "\n")
if (prop.t)
cat(gettext("| Total Percent |", domain = "R-descr"), "\n")
}
if (resid)
cat(gettext("| Residual |", domain = "R-descr"), "\n")
if (sresid)
cat(gettext("| Std Residual |", domain = "R-descr"), "\n")
if (asresid)
cat(gettext("| Adj Std Resid |", domain = "R-descr"), "\n")
cat("|-------------------------|\n")
}
## Print 1 X N vector
if (vector.x) {
## Set consistent column widths based upon dimnames and table values
strt <- formatC(unclass(tab), digits = dgts$prop, format = "f", width = 0, decimal.mark = outDec)
CWidth <- max(dgts$prop + 2, c(nchar(strt, type = "width"),
nchar(dimnames(tab)[[2]], type = "width")))
if(prop.r){
if(vector.x)
strt <- formatC(unclass(CPT), digits = dgts$prop, format = "f", width = 0, decimal.mark = outDec)
CWidth <- max(CWidth, nchar(strt, type = "width"))
}
## Create row separators
RowSep <- paste(rep("-", CWidth + 2), collapse = "")
if(is.na(max.width))
max.width = floor((getOption("width") - 2) / (CWidth + 3))
if (length(tab) > max.width) {
## set breakpoints for output based upon max.width
final.row <- length(tab) %% max.width
max <- length(tab) - final.row
## Define breakpoint indices for each row
start <- seq(1, max, max.width)
end <- start + (max.width - 1)
## Add final.row if required
if (final.row > 0) {
start <- c(start, end[length(end)] + 1)
end <- c(end, end[length(end)] + final.row)
}
} else {
## Each value printed horizontally in a single row
start <- 1
end <- length(tab)
}
cat("\n")
for (i in 1:length(start)) {
cat("| ")
cat(paste(formatC(dimnames(tab)[[2]][start[i]:end[i]], width = CWidth, format = "s"), collapse = " | "))
cat(" |\n|")
cat(rep(RowSep, (end[i] - start[i]) + 1), sep = "|")
cat("|\n| ")
cat(formatC(tab[, start[i]:end[i]], width = CWidth, format = "d"), sep = " | ")
if(prop.r){
cat(" |\n| ")
cat(formatC(CPT[, start[i]:end[i]] * hdd, width = CWidth,
digits = dgts$prop, format = "f", decimal.mark = outDec), sep = " | ")
}
cat(" |\n|")
cat(rep(RowSep, (end[i] - start[i]) + 1), sep = "|")
cat("|\n\n")
} ## End of for (i in 1:length(start))
if(format == "SPSS" && GT < TotalN)
cat("\n", gettext("Number of Missing Observations:", domain = "R-descr"),
" ", TotalN-GT, " (", 100*(TotalN-GT)/TotalN, "%)\n", sep = "")
return(invisible(x))
} ## End of if (vector.x)
nr <- nrow(nt)
nc <- ncol(nt)
rnames <- rownames(nt)
cnames <- colnames(nt)
# Check column widths and fix them if necessary
availablewidth <- getOption("width")
minColWd <- max(nchar(nt, type = "width"))
clabwidth <- nchar(cnames, type = "width")
rlabwidth <- max(nchar(rnames, type = "width"), nchar(RowData, type = "width")) + 1
totalwidth <- rlabwidth + (sum(clabwidth + 3))
# Abbreviate row and column labels. Withdraw one char of the newlimit
# label until the rows fit in the screen
while(totalwidth > availablewidth){
newlimit <- max(c(rlabwidth - 1, clabwidth)) - 1
# FIXME: The algorithm should consider the minColWd of each column
if(newlimit < minColWd)
break
rnames <- sapply(rnames, Abbrev1, newlimit)
cnames <- sapply(cnames, Abbrev1, newlimit)
RowData <- Abbrev1(RowData, newlimit)
clabwidth <- nchar(cnames, type = "width")
clabwidth[clabwidth < minColWd] <- minColWd
rlabwidth <- max(nchar(rnames, type = "width"), nchar(RowData, type = "width")) + 1
totalwidth <- rlabwidth + (sum(clabwidth + 3))
}
minColWd <- apply(nt, 2, function(x) max(nchar(x, type = "width")))
clabwidth <- apply(cbind(clabwidth, minColWd), 1, max)
dashedline <- rep("-", sum(clabwidth) + 3 * nc + rlabwidth)
ddashedline <- gsub("-", "=", dashedline)
# Calculate horizontal line locations
if(x$total.c && !is.na(x$prop.col)[1])
nrnt <- nrow(nt) - 2
else if(x$total.c)
nrnt <- nrow(nt) - 1
else
nrnt <- nrow(nt)
n <- nrnt / nrow(tab)
idxh <- seq(n+1, nrnt+1, n)
# idxh <- idxh[idxh < nrow(nt)] # necessary when total.c = FALSE
## Print table cells
cat("\n", ddashedline, "\n", sep = "")
if(ColData != "")
cat(formatC(" ", width = rlabwidth), " ", ColData, "\n", sep = "", collapse = "")
if(RowData == "")
cat(formatC(" ", width = rlabwidth))
else
cat(formatC(RowData, width = rlabwidth, format = "s", flag = "-"))
for(j in 1:nc)
cat(" ", formatC(cnames[j], width = clabwidth[j]))
cat("\n", dashedline, "\n", sep = "")
for(i in 1:nr){
if(i %in% idxh)
cat(dashedline, "\n", sep = "")
cat(formatC(rnames[i], width = rlabwidth, format = "s", flag = "-"), sep = "")
if(x$percent && (prop.r || prop.c || prop.t)){
for(j in 1:nc)
if(grepl("%", nt[i, j]))
cat(" ", formatC(nt[i, j], width = clabwidth[j]), sep = "")
else
cat(" ", formatC(nt[i, j], width = clabwidth[j]), " ", sep = "")
} else {
for(j in 1:nc)
cat(" ", formatC(nt[i, j], width = clabwidth[j]))
}
cat("\n")
}
cat(ddashedline, "\n", sep = "")
## Print Statistics
if (chisq)
{
cat("\n")
cat(gettext("Statistics for All Table Factors", domain = "R-descr"),
"\n\n", sep="")
cat(CST$method, "\n")
cat("------------------------------------------------------------\n")
fp <- format.pval(CST$p.value, digits = dgts$others)
pv <- paste("p", if(substr(fp, 1L, 1L) == "<") fp else paste("=", fp))
cat(gettext("Chi^2 =", domain = "R-descr"), CST$statistic,
" ", gettext("d.f. =", domain = "R-descr"), CST$parameter,
" ", pv, "\n\n")
if (all(dim(tab) == 2))
{
cat(CSTc$method, "\n")
cat("------------------------------------------------------------\n")
fp <- format.pval(CSTc$p.value, digits = dgts$others)
pv <- paste("p", if(substr(fp, 1L, 1L) == "<") fp else paste("=", fp))
cat(gettext("Chi^2 =", domain = "R-descr"), CSTc$statistic,
" ", gettext("d.f. =", domain = "R-descr"), CSTc$parameter,
" ", pv, "\n")
}
}
## Print McNemar tests
if (is.na(McN[1]) == FALSE)
{
cat(rep("\n", 2))
cat(McN$method, "\n")
cat("------------------------------------------------------------\n")
fp <- format.pval(McN$p.value, digits = dgts$others)
pv <- paste("p", if(substr(fp, 1L, 1L) == "<") fp else paste("=", fp))
cat(gettext("Chi^2 =", domain = "R-descr"), McN$statistic,
" ", gettext("d.f. =", domain = "R-descr"), McN$parameter,
" ", pv, "\n\n")
if (is.na(McNc[1]) == FALSE)
{
cat(McNc$method, "\n")
cat("------------------------------------------------------------\n")
fp <- format.pval(McNc$p.value, digits = dgts$others)
pv <- paste("p", if(substr(fp, 1L, 1L) == "<") fp else paste("=", fp))
cat(gettext("Chi^2 =", domain = "R-descr"), McNc$statistic,
" ", gettext("d.f. =", domain = "R-descr"), McNc$parameter,
" ", pv, "\n")
}
}
## Pint Fisher Tests
if (fisher)
{
cat(rep("\n", 2))
cat(gettext("Fisher's Exact Test for Count Data", domain = "R-descr"))
cat("\n------------------------------------------------------------\n")
if (all(dim(tab) == 2))
{
cat(gettext("Sample estimate odds ratio:", domain = "R-descr"), FTt$estimate, "\n\n")
cat(gettext("Alternative hypothesis: true odds ratio is not equal to 1",
domain = "R-descr"), "\n")
fp <- format.pval(FTt$p.value, digits = dgts$others)
pv <- paste("p", if(substr(fp, 1L, 1L) == "<") fp else paste("=", fp))
cat(pv, "\n")
cat(gettextf("95%s confidence interval:", "%", domain = "R-descr"), FTt$conf.int, "\n\n")
cat(gettext("Alternative hypothesis: true odds ratio is less than 1",
domain = "R-descr"), "\n")
fp <- format.pval(FTl$p.value, digits = dgts$others)
pv <- paste("p", if(substr(fp, 1L, 1L) == "<") fp else paste("=", fp))
cat(pv, "\n")
cat(gettext("95%s confidence interval:", "%", domain = "R-descr"), FTl$conf.int, "\n\n")
cat(gettext("Alternative hypothesis: true odds ratio is greater than 1",
domain = "R-descr"), "\n")
fp <- format.pval(FTg$p.value, digits = dgts$others)
pv <- paste("p", if(substr(fp, 1L, 1L) == "<") fp else paste("=", fp))
cat(pv, "\n")
cat(gettext("95%s confidence interval:", "%", domain = "R-descr"), FTg$conf.int, "\n\n")
}
else
{
cat(gettext("Alternative hypothesis: two.sided", domain = "R-descr"), "\n")
fp <- format.pval(FTt$p.value, digits = dgts$others)
pv <- paste("p", if(substr(fp, 1L, 1L) == "<") fp else paste("=", fp))
cat(pv, "\n")
}
} ## End Of If(Fisher) Loop
# cat(rep("\n", 2))
if(format == "SPSS"){
if (any(dim(tab) >= 2) & any(chisq, mcnemar, fisher))
{
MinExpF = min(CST$expected)
cat(" ", gettext("Minimum expected frequency:", domain = "R-descr"), MinExpF, "\n")
NMinExpF = length(CST$expected[which(CST$expected<5)])
if (NMinExpF > 0)
{
NCells = length(CST$expected)
cat(gettext("Cells with Expected Frequency < 5:", domain = "R-descr"),
" ", NMinExpF, " ", gettext("of", domain = "R-descr"), " ",
NCells, " (", 100*NMinExpF/NCells, "%)\n", sep = "")
}
cat("\n")
} ## End of if (any(dim(tab)...))
}
return(invisible(x))
}
as.data.frame.CrossTable <- function(x, ...) as.data.frame(x$tab, ...)
# Needed by tableStyles() of odfWeave package:
dim.CrossTable <- function(x){
dim(x$tab) + 1
}
Try the descr package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.