R/fs_bytes.R

In fs: Cross-Platform File System Operations Based on 'libuv'

units <- c('B' = 1, 'K' = 1024, 'M' = 1024 ^ 2, 'G' = 1024 ^ 3, 'T' = 1024 ^ 4, 'P' = 1024 ^ 5, 'E' = 1024 ^ 6, 'Z' = 1024 ^ 7, 'Y' = 1024 ^ 8)

#' Human readable file sizes
#'
#' Construct, manipulate and display vectors of file sizes. These are numeric
#' vectors, so you can compare them numerically, but they can also be compared
#' to human readable values such as '10MB'.
#'
#' @param x A numeric or character vector. Character representations can use
#'   shorthand sizes (see examples).
#' @examples
#' fs_bytes("1")
#' fs_bytes("1K")
#' fs_bytes("1Kb")
#' fs_bytes("1Kib")
#' fs_bytes("1MB")
#'
#' fs_bytes("1KB") < "1MB"
#'
#' sum(fs_bytes(c("1MB", "5MB", "500KB")))
#' @name fs_bytes
#' @export
as_fs_bytes <- function(x) {
  UseMethod("as_fs_bytes")
}

#' @export
#' @rdname fs_bytes
fs_bytes <- as_fs_bytes

new_fs_bytes <- function(x) {
  class(x) <- c("fs_bytes", "numeric")
  x
}
setOldClass(c("fs_bytes", "numeric"), numeric())

#' @export
as_fs_bytes.default <- function(x = numeric()) {
  if (length(x) == 0) {
    return(new_fs_bytes(numeric()))
  }
  x <- as.character(x)
  m <- captures(x, regexpr("^(?<size>[[:digit:].]+)\\s*(?<unit>[KMGTPEZY]?)i?[Bb]?$", x, perl = TRUE))
  m$unit[m$unit == ""] <- "B"
  new_fs_bytes(unname(as.numeric(m$size) * units[m$unit]))
}

#' @export
as_fs_bytes.fs_bytes <- function(x) {
  return(x)
}

#' @export
as_fs_bytes.numeric <- function(x) {
  new_fs_bytes(x)
}

# Adapted from https://github.com/gaborcsardi/prettyunits
# Aims to be consistent with ls -lh, so uses 1024 KiB units, 3 or less digits etc.
#' @export
format.fs_bytes <- function(x, scientific = FALSE, digits = 3, drop0trailing = TRUE, ...) {
  bytes <- unclass(x)

  exponent <- pmin(floor(log(bytes, 1024)), length(units) - 1)
  res <- round(bytes / 1024 ^ exponent, 2)
  unit <- ifelse (exponent == 0, "", names(units)[exponent + 1])

  ## Zero bytes
  res[bytes == 0] <- 0
  unit[bytes == 0] <- ""

  ## NA and NaN bytes
  res[is.na(bytes)] <- NA_real_
  res[is.nan(bytes)] <- NaN
  unit[is.na(bytes)] <- ""            # Includes NaN as well

  res <- format(res, scientific = scientific, digits = digits, drop0trailing = drop0trailing, ...)

  paste0(res, unit)
}

#' @export
as.character.fs_bytes <- format.fs_bytes

#' @export
print.fs_bytes <- function(x, ...) {
  cat(format.fs_bytes(x, ...))
}

#' @export
sum.fs_bytes <- function(x, ...) {
  new_fs_bytes(NextMethod())
}

#' @export
min.fs_bytes <- function(x, ...) {
  new_fs_bytes(NextMethod())
}

#' @export
max.fs_bytes <- function(x, ...) {
  new_fs_bytes(NextMethod())
}

#' @export
`[.fs_bytes` <- function(x, i, ...) {
  new_fs_bytes(NextMethod("["))
}

#' @export
`[[.fs_bytes` <- function(x, i, ...) {
  new_fs_bytes(NextMethod("[["))
}

#' @export
# Adapted from Ops.numeric_version
Ops.fs_bytes <- function (e1, e2) {
  if (nargs() == 1L) {
    stop(sprintf("unary '%s' not defined for \"fs_bytes\" objects", .Generic),
      call. = FALSE)
  }

  boolean <- switch(.Generic,
    `+` = TRUE,
    `-` = TRUE,
    `*` = TRUE,
    `/` = TRUE,
    `^` = TRUE,
    `<` = TRUE,
    `>` = TRUE,
    `==` = TRUE,
    `!=` = TRUE,
    `<=` = TRUE,
    `>=` = TRUE,
  FALSE)
  if (!boolean) {
    stop(sprintf("'%s' not defined for \"fs_bytes\" objects", .Generic),
      call. = FALSE)
  }
  e1 <- as_fs_bytes(e1)
  e2 <- as_fs_bytes(e2)
  NextMethod(.Generic)
}

pillar_shaft.fs_bytes <- function(x, ...) {
  pillar::new_pillar_shaft_simple(format.fs_bytes(x), align = "right", ...)
}

type_sum.fs_bytes <- function(x) {
  "fs::bytes"
}

# All functions below registered in .onLoad

vec_ptype2.fs_bytes.fs_bytes <- function(x, y, ...) {
  x
}
vec_ptype2.fs_bytes.double <- function(x, y, ...) {
  x
}
vec_ptype2.double.fs_bytes <- function(x, y, ...) {
  y
}

# Note order of class is the opposite as for ptype2
vec_cast.fs_bytes.fs_bytes <- function(x, to, ...) {
  x
}
vec_cast.fs_bytes.double <- function(x, to, ...) {
  as_fs_bytes(x)
}
vec_cast.double.fs_bytes <- function(x, to, ...) {
  unclass(x)
}

vec_ptype2.fs_bytes.integer <- function(x, y, ...) {
  x
}
vec_ptype2.integer.fs_bytes <- function(x, y, ...) {
  y
}

vec_cast.fs_bytes.integer <- function(x, to, ...) {
  as_fs_bytes(x)
}
vec_cast.integer.fs_bytes <- function(x, to, ...) {
  unclass(x)
}