R/human_readable.R

In moj-analytical-services/s3tools: Tools to help explore Amazon S3

# From https://github.com/cran/gdata/blob/master/R/humanReadable.R to avoid dependency

humanReadable <- function(x,
                          units="auto",
                          standard=c("IEC", "SI", "Unix"),
                          digits=1,
                          width=NULL,
                          sep=" ",
                          justify = c("right", "left")
)
{
  ## --- Setup ---
  
  suffix.SI   <- c("B",  "kB",  "MB",  "GB",  "TB",  "PB",  "EB",  "ZB",  "YB")
  suffix.IEC  <- c("B", "KiB", "MiB", "GiB", "TiB", "PiB", "EiB", "ZiB", "YiB")
  suffix.Unix <- c("B" ,  "K",   "M",   "G",   "T",   "P",   "E",   "Z",   "Y")
  
  standard <- match.arg(standard)
  if(length(justify)==1) justify <- c(justify, justify)
  
  ## --- Functions ---
  
  .applyHuman <- function(x, base, suffix, digits, width, sep)
  {
    ## Which suffix should we use?
    n <- length(suffix)
    i <- pmax(pmin(floor(log(x, base)), n-1),0)
    if(!is.finite(i)) i <- 0
    x <- x / base^i
    ## Formatting
    if(is.null(width))
      ## the same formatting for all
      x <- format(round(x=x, digits=digits), nsmall=digits)
    else
    {
      ## similar to ls, du, and df
      lenX <- nchar(x)
      if(lenX > width) {
        digits <- pmax( width - nchar(round(x)) - 1, 0)
      }
      if(i == 0) digits <- 0
      x <- round(x, digits=digits)
    }
    c(x, suffix[i+1])
  }
  
  ## -- Work
  
  if(any(x < 0)) stop("'x' must be positive")
  if(standard == "SI")
  {
    suffix <- suffix.SI
    base <- 10^3
  }
  else if (standard=="IEC")
  {
    suffix <- suffix.IEC
    base <- 2^10
  }
  else # (standard=="Unix)
  {
    suffix <- suffix.Unix
    base <- 2^10
  }
  
  if(!missing(units) && units=="bytes")
  {
    retval <- rbind(x, "bytes")
  }
  else if(!missing(units) && units!="auto")
  {
    units <- suffix[match( toupper(units), toupper(suffix) )]
    power <- match(units, suffix ) -1
    X <- x/(base^power)
    X <- format.default(x=X, digits=digits, nsmall=digits)
    retval <- rbind(X, rep(units, length(X)))
  }
  else
    retval <- sapply(X=x, FUN=".applyHuman", base=base, suffix=suffix,
                     digits=digits, width=width, sep=sep)
  
  if(all(justify == "none"))
    paste(trim(retval[1,]), trim(retval[2,]), sep=sep)
  else
    paste(format(trim(retval[1,]), justify=justify[1]),
          format(trim(retval[2,]), justify=justify[2]),
          sep=sep)
  
}

trim <- function(s, recode.factor=TRUE, ...)
  UseMethod("trim", s)

trim.default <- function(s, recode.factor=TRUE, ...)
  s

trim.character <- function(s, recode.factor=TRUE, ...)
{
  s <- sub(pattern="^[[:blank:]]+", replacement="", x=s)
  s <- sub(pattern="[[:blank:]]+$", replacement="", x=s)
  s
}

trim.factor <- function(s, recode.factor=TRUE, ...)
{
  levels(s) <- trim(levels(s))
  if(recode.factor) {
    dots <- list(x=s, ...)
    if(is.null(dots$sort)) dots$sort <- sort
    s <- do.call(what="reorder.factor", args=dots)
  }
  s
}

trim.list <- function(s, recode.factor=TRUE, ...)
  lapply(s, trim, recode.factor=recode.factor, ...)

trim.data.frame <- function(s, recode.factor=TRUE, ...)
{
  s[] <- trim.list(s, recode.factor=recode.factor, ...)
  s
}