R/rle2.R

In twolodzko/twextras: twextras

#' Improved Run Length Encoding
#' 
#' @param x         vector
#' @param change    expected change between subsequent values;
#'                  \code{change=0} (default) leads to behaviour of \code{\link{rle}};
#'                  \code{change=1} is sequence of values increasing by one, etc. 
#'                  For \code{character} and \code{factor} vectors this parameter is ignored.
#' @param tolerance numeric value; maximal difference between subsequent values.
#'                  For \code{character} and \code{factor} vectors this parameter is ignored;
#'                  for \code{integer} and \code{Date} vectors it is \code{0} by default.
#' 
#' @export

rle2 <- function(x, change, tolerance) UseMethod("rle2")


#' @rdname rle2
#' @export

rle2.default <- function(x, change = 0, tolerance = sqrt(.Machine$double.eps)) {
  structure(
    cpp_rle2(x, change, tolerance),
    settings = list(
      change = change,
      tolerance = tolerance
    ),
    class = "rle2"
  )
}


#' @rdname rle2
#' @export

rle2.integer <- function(x, change = 0, tolerance = 0) {
  structure(
    cpp_rle2(x, change, tolerance),
    settings = list(
      change = change,
      tolerance = tolerance
    ),
    class = "rle2"
  )
}


#' @rdname rle2
#' @export

rle2.factor <- function(x, change = NULL, tolerance = NULL) {
  if ( (!is.null(change) && change != 0) || (!is.null(tolerance) && tolerance != 0) )
    warning("for character and factor vectors parameters 'change' and 'tolerance' are ignored")
  structure(
    cpp_rle2(as.integer(x), 0, 0),
    settings = list(
      change = 0,
      tolerance = 0
    ),
    class = "rle2"
  )
}


#' @rdname rle2
#' @export

rle2.character <- function(x, change = NULL, tolerance = NULL) {
  if ( (!is.null(change) && change != 0) || (!is.null(tolerance) && tolerance != 0) )
    warning("for character and factor vectors parameters 'change' and 'tolerance' are ignored")
  structure(
    cpp_rle2(as.integer(as.factor(x)), 0, 0),
    settings = list(
      change = 0,
      tolerance = 0
    ),
    class = "rle2"
  )
}


#' @rdname rle2
#' @export

rle2.Date <- function(x, change = 0, tolerance = 0) {
  structure(
    cpp_rle2(as.numeric(x), change, tolerance),
    settings = list(
      change = change,
      tolerance = tolerance
    ),
    class = "rle2"
  )
}


#' @export


print.rle2 <- function (x, digits = getOption("digits"), prefix = "", ...) {
  if (is.null(digits)) 
    digits <- getOption("digits")
  cat("", "Run Length Encoding\n", "  lengths     :", sep = prefix)
  utils::str(x$lengths[x$changepoints])
  cat("", "  changepoints:", sep = prefix)
  utils::str(x$changepoints, digits.d = digits)
  if (attr(x, "settings")$change != 0)
    cat("", "  step        : ", attr(x, "settings")$change, "\n", sep = prefix)
  if (attr(x, "settings")$tolerance > 0)
    cat("", "  tolerance   : ", attr(x, "settings")$tolerance, sep = prefix)
  invisible(x)
}