# [R] Contingency tables from data.frames

Jose Claudio Faria joseclaudio.faria at terra.com.br
Fri May 27 11:39:32 CEST 2005

```The final version with the help of Gabor Grotendieck (thanks Gabor, very much!)

#######################
#   EasieR - Package  #
#######################

# Common function
er.make.table <- function(x,
start,
end,
h,
right) {
# Absolut frequency
f <- table(cut(x, br=seq(start, end, h), right=right))

# Relative frequency
fr <- f/length(x)

# Relative frequency, %
frP <- 100*(f/length(x))

# Cumulative frequency
fac <- cumsum(f)

# Cumulative frequency, %
facP <<- 100*(cumsum(f/length(x)))

fi   <- round(f, 2)
fr   <- round(as.numeric(fr), 2)
frP  <- round(as.numeric(frP), 2)
fac  <- round(as.numeric(fac), 2)
facP <- round(as.numeric(facP),2)

# Make final table
res <- data.frame(fi, fr, frP, fac, facP)
names(res) <- c('Class limits', 'fi', 'fr', 'fr(%)', 'fac', 'fac(%)')
return(res)

}

#With Gabor Grotendieck suggestions (thanks Gabor, very much!)
er.table <- function(x, ...) UseMethod("er.table")

er.table.default <- function(x,
k,
start,
end,
h,
breaks=c('Sturges', 'Scott', 'FD'),
right=FALSE) {

#User define nothing or not 'x' isn't numeric -> stop
stopifnot(is.numeric(x))

#User define only 'x'
#(x, {k, start, end, h}, [breaks, right])
if (missing(k) && missing(start) && missing(end) && missing(h) ){

x <- na.omit(x)

brk <- match.arg(breaks)
switch(brk,
Sturges = k <- nclass.Sturges(x),
Scott   = k <- nclass.scott(x),
FD      = k <- nclass.FD(x))

tmp   <- range(x)
start <- tmp[1] - abs(tmp[2])/100
end   <- tmp[2] + abs(tmp[2])/100
R     <- end-start
h     <- R/k

}

#User define 'x' and 'k'
#(x, k, {start, end, h}, [breaks, right])
else if (missing(start) && missing(end) && missing(h)) {

stopifnot(length(k) >= 1)

x <- na.omit(x)

tmp   <- range(x)
start <- tmp[1] - abs(tmp[2])/100
end   <- tmp[2] + abs(tmp[2])/100
R     <- end-start
h     <- R/abs(k)

}

#User define 'x', 'start' and 'end'
#(x, {k,} start, end, {h,} [breaks, right])
else if (missing(k) && missing(h)) {

stopifnot(length(start) >= 1, length(end) >=1)

x <- na.omit(x)

tmp <- range(x)
R   <- end-start
k   <- sqrt(abs(R))
if (k < 5)  k <- 5 #min value of k
h   <- R/k

}

#User define 'x', 'start', 'end' and 'h'
#(x, {k,} start, end, h, [breaks, right])
else if (missing(k)) {

stopifnot(length(start) >= 1, length(end) >= 1, length(h) >= 1)
x <- na.omit(x)

}

else stop('Error, please, see the function sintax!')

tbl <- er.make.table(x, start, end, h, right)
return(tbl)

}

er.table.data.frame <- function(df,
k,
breaks=c('Sturges', 'Scott', 'FD'),
right=FALSE) {

stopifnot(is.data.frame(df))

tmpList <- list()
logCol  <- sapply(df, is.numeric)

for (i in 1:ncol(df)) {

if (logCol[i]) {

x <- as.matrix(df[ ,i])
x <- na.omit(x)

#User define only x and/or 'breaks'
#(x, {k,}[breaks, right])
if (missing(k)) {

brk <- match.arg(breaks)
switch(brk,
Sturges = k <- nclass.Sturges(x),
Scott   = k <- nclass.scott(x),
FD      = k <- nclass.FD(x))

tmp   <- range(x)
start <- tmp[1] - abs(tmp[2])/100
end   <- tmp[2] + abs(tmp[2])/100
R     <- end-start
h     <- R/k

}

#User define 'x' and 'k'
#(x, k,[breaks, right])
else {

tmp   <- range(x)
start <- tmp[1] - abs(tmp[2])/100
end   <- tmp[2] + abs(tmp[2])/100
R     <- end-start
h     <- R/abs(k)

}

tbl     <- er.make.table(x, start, end, h, right)
tmpList <- c(tmpList, list(tbl))

}

}

valCol <- logCol[logCol]
names(tmpList) <- names(valCol)
return(tmpList)

}

Best,
--
Jose Claudio Faria
Brasil/Bahia/UESC/DCET