pkg/R/autoformat.R

   1 autoformat <- function(xtab, zap = getOption("digits")) {
   2   align(xtab) <- xalign(xtab)
   3   digits(xtab) <- xdigits(xtab, zap = zap)
   4   display(xtab) <- xdisplay(xtab)
   5   return(xtab)
   6 }
   7
   8 xalign <- function(x, pad = TRUE) {
   9   lr <- function(v) if(is.numeric(v)) "r" else "l"
  10
  11   is.2d <- length(dim(x)) == 2
  12   alignment <- if(is.2d) sapply(as.data.frame(x), lr) else lr(x)
  13   output <- if(is.2d && pad) c("l", alignment) else alignment
  14
  15   return(output)
  16 }
  17
  18 xdigits <- function(x, pad = TRUE, zap = getOption("digits")) {
  19   dig <- function(v) {
  20     if(is.numeric(v)) {
  21       v <- na.omit(v)
  22       v <- zapsmall(abs(v - floor(v)), zap)
  23       dec <- if(any(v > 0)) max(nchar(v) - 2L) else 0L
  24     } else {
  25       dec <- 0L
  26     }
  27     return(dec)
  28   }
  29
  30   is.2d <- length(dim(x)) == 2
  31   decimals <- if(is.2d) sapply(as.data.frame(x), dig) else dig(x)
  32   output <- if(is.2d && pad) c(0L, decimals) else decimals
  33
  34   return(output)
  35 }
  36
  37 xdisplay <- function(x, pad = TRUE) {
  38   type <- function(v) {
  39     if(is.numeric(v)) {
  40       tp <- if(xdigits(v) == 0) "d" else "f"
  41     } else {
  42       tp <- "s"
  43     }
  44     return(tp)
  45   }
  46
  47   is.2d <- length(dim(x)) == 2
  48   disp <- if(is.2d) sapply(as.data.frame(x), type) else type(x)
  49   output <- if(is.2d && pad) c("s", disp) else disp
  50
  51   return(output)
  52 }
  53