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

   1 #' Wrap Prefix and Suffix around Strings
   2 #'
   3 #' Wrap (bracket) strings by adding suffix and prefix to each string provided.
   4 #'
   5 #' If \code{e2} is a single value it is concanted to both sides of the target strings. If \code{e2} has two values, the first is added to the left and the second to the right of the target string. If \code{e2} is longer than the pairs cycled, and if the total number is odd, the the last element is applied to both sides of the target.
   6 #'
   7 #' If empty string are proved in \code{e2}, the operator can be used to just add a suffix or a prefix.
   8 #'
   9 #' If \code{e1} is named, these names will be preserved and returned. Names associated with \code{e2} are ignored.
  10 #' @param e1 character strings (or elements that can be coerced to character) to be wrapped. This can be a vector, list or nested lists.
  11 #' @param e2 character vector (or list) of strings (or elements that can be coerced to character) to be applied as wrappers, and with names retained.
  12 #' @return A character vector (or structure as supplied) with each element wrapped with the string provided
  13 #' @examples
  14 #' letters %w% "."
  15 #' 0:20 %w% c("(", ")", "<", ">", ".")
  16 #' # e2 longer, extras ignored
  17 #' rep("-", 10) %w% letters
  18 #' @export
  19 `%w%` <- function(e1, e2) {
  20 	named <- (!is.null(names(e1)))
  21 	.e1 <- unlist(e1)
  22 	.e2 <- unlist(e2)
  23 	i <- 0L ; j <- 1L
  24 	.e1 <- vapply(.e1, function(x) {
  25 		i <<- i + 1L
  26 		if (i > length(.e2)) i <<- 1L
  27 		j <<- i + 1L
  28 		if (j > length(.e2)) j <<- i
  29 		x <- paste0(.e2[i], x, .e2[j])
  30 		if (j > i) i <<- i + 1L
  31 		return(x)
  32 		}, "", USE.NAMES = FALSE)
  33 	relist(.e1, e1)
  34 }
  35 
  36 #' Paste Suffix on Strings
  37 #'
  38 #' Add suffix to strings by appending strings provided.
  39 #'
  40 #' The shorter of the two arguments is recycled, so the returned result is always the length of the longer argument. Names are preserved, with names of the first argument taking precedence.
  41 #'
  42 #' @param e1 character strings (or elements that can be coerced to character) to be wrapped. This can be a vector, list or nested lists. If longer than \code{e2}, then \code{e2} is recycled.
  43 #' @param e2 character strings (or elements that can be coerced to character) to be applied as suffixes. If longer than \code{e1}, then \code{e1} is recycled.
  44 #' @return A character vector (or structure as supplied) with each element appended with the strings provided. The struture of the first argument will be retained, but this may fail if second arguement is longer. Name are preserved, with the first argument taking precedence.
  45 #' @examples
  46 #' # e2 shorter and recycled
  47 #' letters[1:10] %p% 1:5
  48 #' # e1 shorter and recycled
  49 #' letters[1:10] %p% 1:20
  50 #' # names preserved
  51 #' setNames(1:5, letters[1:5]) %p% "_"
  52 #' @export
  53 `%p%` <- function(e1, e2) {
  54 	.e1 <- unlist(e1)
  55 	.e2 <- unlist(e2)
  56 	i <- 0L
  57 	if (length(.e1) >= length(.e2)) {
  58 		.e1 <- vapply(.e1, function(x) {
  59 			i <<- i + 1L 
  60 			if (i > length(.e2)) i <<- 1L
  61 			paste0(x, .e2[i])
  62 			}, "", USE.NAMES = FALSE)
  63 	} else {
  64 		.e1 <- vapply(.e2, function(x) {
  65 			i <<- i + 1L 
  66 			if (i > length(.e1)) i <<- 1L
  67 			paste0(.e1[i], x)
  68 			}, "", USE.NAMES = FALSE)		
  69 	}
  70 	if (is.null(names(e1)) && !is.null(names(e2)))
  71 		names(e1) <- rep(names(e2), len = length(e1))
  72 	relist(.e1, e1)
  73 }