attachment:contractSeqs.R of R Coding/local-package

   1 #' Test Integers are in Sequence
   2 #'
   3 #' Test if items in an integer vector are within a sequence.
   4 #' @param x an integer vector, or a vector that can be coerced to integer by \code{as.integer(x)}.
   5 #' @return If items are within a sequence (a run of 3 or more integers), TRUE is returned, otherwise FALSE is returned. NAs are also returned as FALSE.
   6 #' @examples
   7 #' in.seq(c(1:3,NA,5:7))
   8 #' in.seq(as.character(1:5))
   9 #' @export
  10 in.seq <- function(x)
  11 {
  12 	x <- as.integer(x)
  13 	if (length(x) < 3)
  14 		return(x & FALSE)
  15 	d1 <- c(diff(x, 1), NA)
  16 	d2 <- c(NA, diff(x, 2), NA)
  17 	result <- ((d1 == 1 & d2 == 2) | (d1 == -1 & d2 == -2))
  18 	result[is.na(result)] <- FALSE
  19 	return(result)
  20 }
  21 		
  22 #' Escape Regex Charaters in a String
  23 #'
  24 #' Regex metacharacters to escape: \code{. \\ | ( ) [ \{ ^ $ * + ?}
  25 #' @param x a character vector, or an object that can be coerced to character by \code{as.character(x)}.
  26 #' @return Charaters in x are escaped, e.g., the dot "." is escaped to "\\.".
  27 #' @examples
  28 #' pattern <- escRegex(".")
  29 #' gsub(pattern, '-', '12.05.2018')
  30 #' @export
  31 escRegex <- function(x)
  32 {
  33 	return(gsub("([.\\|()[\\{^$*+?])", "\\\\\\1", x))
  34 }
  35 
  36 #' Contract sequences with continous elements as ranges
  37 #'
  38 #' @param x a numeric integer vector, or string or character vector that can be coerced into a numeric vector.
  39 #' @param rng a character string to indicate a range.
  40 #' @param sep a character srting for separating values.
  41 #' @param conj a charater string to separate the last to values instead of sep.
  42 #' @param empty a charater string to returned, if processing of \code{x} fails.
  43 #' @return A formatted string with ranges contracted and each element delimited as spedcific by \code{sep} and \code{conj}.
  44 #' @examples
  45 #' s <- "1,2,3,4,8,9,16,15,14,19"
  46 #' contractSeqs(s)
  47 #' s1 <- unlist(strsplit(s, ","))
  48 #' contractSeqs(s1)
  49 #' contractSeqs(as.numeric(s1), sep= "; ", conj = " and ")
  50 #' @rdname contractSeqs
  51 #' @export
  52 contractSeqs <- function(x, rng = "-", sep = ",", conj = sep, empty = "")
  53 	UseMethod("contractSeqs", x)
  54 #' @return 
  55 #'
  56 #' @rdname contractSeqs
  57 #' @method contractSeqs numeric
  58 #' @export
  59 contractSeqs.numeric <- function(x, rng = "-", sep = ",", conj = sep, empty = "")
  60 {
  61 	pattern1 <- sprintf("(%s){2,}", escRegex(sep))
  62 	pattern2 <- sprintf("%s(((?!%s).){1,}$)", escRegex(sep), escRegex(sep))
  63 	pattern3 <- sprintf("%s\\1", conj)
  64 	x[in.seq(x)] <- ""
  65 	result <- gsub(pattern1, rng, paste(x, collapse = sep), perl = TRUE)
  66 	if (conj != sep) 
  67 		result <- gsub(pattern2, pattern3, result, perl = TRUE)
  68 	return(result)
  69 }
  70 #' @return
  71 #'
  72 #' @rdname contractSeqs
  73 #' @method contractSeqs character
  74 #' @export
  75 contractSeqs.character <- function(x, rng = "-", sep = ",", conj = sep, empty = "")
  76 {
  77 	msg <- "%s could not be coerced to numeric: returning empty string"
  78 	ln <- length(x)
  79 	if (ln == 0) return(empty)
  80 	if (ln == 1) msg <- sprintf(msg, "string")
  81 	if (ln > 1) {
  82 		x <- toString(x) #for character vectors
  83 		msg <- sprintf(msg, "vector")
  84 	}
  85 	x <- try(eval(parse(text=sprintf("c(%s)", x))), silent = TRUE)
  86 	if (is.numeric(x)) {
  87 		contractSeqs(x, rng = rng, sep = sep, conj = conj, empty = empty)
  88 	} else {
  89 		warning(msg)
  90 		return(empty)
  91 	}
  92 }
  93 #' @return 
  94 #'
  95 #' @rdname contractSeqs
  96 #' @method contractSeqs default
  97 #' @export
  98 contractSeqs.default <- function(x, ...)
  99 {
 100 	warning("argument is not character or numeric: returning empty string")
 101 	return(empty)
 102 }