[R] Contingency tables from data.frames

[Jose Claudio Faria]

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
Estatistica Experimental/Prof. Adjunto
mails:
  joseclaudio.faria at terra.com.br
  jc_faria at uesc.br
  jc_faria at uol.com.br
tel: 73-3634.2779