R/string.R

In priscian/jjmisc: Various R Functions to Aid Report Creation

#' Concatenate Strings Easily
#'
#' Allows quick chaining together of character strings.
#'
#' @param a R object to be converted to a character vector.
#' @param b R object to be converted to a character vector.
#' @param sep A character string to separate the terms; passed to \code{\link[base]{paste}()}.
#'
#' @return The concatenation of \code{a} and \code{b}.
#'
#' @seealso \code{\link[base]{paste}}
#'
#' @examples
#' who <- "world"
#' "Hello " %_% who %_% "!"
#'
#' @export
`%_%` <- function(a, b, sep='') paste(a, b, sep=sep)


# ?base::tolower
#' @export
capwords <- function(s, strict = FALSE) {
  cap <- function(s) paste(toupper(substring(s, 1L, 1L)), { s <- substring(s, 2L); if(strict) tolower(s) else s }, sep='', collapse=' ')
  sapply(strsplit(s, split=' '), cap, USE.NAMES=!is.null(names(s)))
}


#' @export
catn <- function (..., prefix="\n", suffix="\n\n", file="", sep="", fill=FALSE, labels=NULL, append=FALSE)
{
  cat(prefix, ..., suffix, file=file, sep=sep, fill=fill, labels=labels, append=append)
}


# http://stackoverflow.com/questions/28248457/gsub-in-r-with-unicode-replacement-give-different-results-under-windows-compared
#' @export
true_unicode <- function(x) {
  packuni <- Vectorize(function(cp) {
    bv <- intToBits(cp)
    maxbit <- tail(which(bv != as.raw(0L)), 1L)
    if(maxbit < 8L)
      rawToChar(as.raw(codepoint))
    else if (maxbit < 12L)
      rawToChar(rev(packBits(c(bv[1L:6L], as.raw(c(0L, 1L)), bv[7L:11L], as.raw(c(0L, 1L, 1L))), "raw")))
    else if (maxbit < 17L)
      rawToChar(rev(packBits(c(bv[1L:6L], as.raw(c(0L, 1L)), bv[7L:12L], as.raw(c(0L, 1L)), bv[13L:16L], as.raw(c(0L, 1L, 1L, 1L))), "raw")))
    else
      stop("Too many bits.")
  })

  m <- gregexpr("<U\\+[0-9a-fA-F]{4}>", x)
  codes <- regmatches(x,m)
  chars <- lapply(codes, function(x) {
    codepoints <- strtoi(paste0("0x", substring(x, 4L, 7L)))
    packuni(codepoints)
  })
  regmatches(x, m) <- chars
  Encoding(x) <- "UTF-8"

  return (x)
}

#' @export
tu <- true_unicode


#' @export
get_formatted_p_value <- function(p.value, le="<", fmt="%1.3f", ...)
{
  if (is.character(p.value))
    return (p.value)

  return (ifelse(p.value < 0.001, le %_% " 0.001", sprintf(fmt, p.value)))
}

#' @export
gfp <- get_formatted_p_value


## V. '?base::grep' from the R command line.
#' @export
parse_one <- function(res, result)
{
  m <- do.call(rbind, lapply(seq_along(res),
    function(i) {
      if (result[i] == -1) return("")
      st <- attr(result, "capture.start")[i, ]
      substring(res[i], st, st + attr(result, "capture.length")[i, ] - 1)
    }))
  colnames(m) <- attr(result, "capture.names")

  m
}