pkg/R/formatHelpers.R

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