R/utils.R

In adayim/cttab: Tables of Descriptive Statistics in word

#' Format number to percent
#' 
#' Format values to percentage format. Multiply 100 and add \% symbol.
#' @param x Number to format percentage.
#' @inheritParams base::formatC 
#'
#' @return A formatted percent character.
#' @export
#'
format_percent <- function(x, digits = 2, format = "f", ...) {
  paste0(formatC(100 * x, format = format, digits = digits, ...), "%")
}


#' Subset function that preserves column attributes.
#'
#' @param x An object to be subsetted (usually a \code{\link{data.frame}}).
#' @param ... Further arguments passed to \code{\link{subset}}.
#' @param droplevels If \code{TRUE} (the default), then unused factor levels are dropped (see \code{\link{droplevels}}).
#' @return An object similar to \code{x} containing just the selected elements.
#' In the case of a \code{\link{data.frame}}, attributes of columns (such as
#' \code{\link{var_lab}}) are preserved.
#' @seealso
#' \code{\link{subset}}
#' \code{\link{droplevels}}
#' @keywords utilities
#' @export
subsetp <- function(x, ..., droplevels = TRUE) {
  y <- subset(x, ...)
  if (droplevels) {
    y <- droplevels(y)
  }
  if (is.data.frame(x)) {
    for (i in seq_along(x)) {
      a <- attributes(x[[i]])
      if (droplevels && is.factor(y[[i]])) {
        a$levels <- attributes(y[[i]])$levels
      }
      attributes(y[[i]]) <- a
    }
  }
  y
}

.isFALSE <- function (x) {
  is.logical(x) && length(x) == 1L && !is.na(x) && !x
}



#' Format p-value
#'
#' @param pvals A numeric value or vector of p-values
#' @param sig.limit Lower bound for precision; smaller values will be shown as < sig.limit
#' @param digits Number of digits past the decimal point to keep
#'
#' @export
#'
#' @examples
#' pv <- c(-1, 0.00001, 0.0042, 0.0601, 0.1335, 0.4999, 0.51, 0.89, 0.9, 1)
#' format_pval(pv)
#' 
format_pval <- function(pvals, sig.limit = .001, digits = 3) {
  
  roundr <- function(x, digits = 1) {
    res <- sprintf(paste0('%.', digits, 'f'), x)
    zzz <- paste0('0.', paste(rep('0', digits), collapse = ''))
    res[res == paste0('-', zzz)] <- zzz
    res
  }
  
  sapply(pvals, function(x, sig.limit) {
    if(is.na(x))
      return(x)
    if (x < sig.limit)
      return(sprintf('<%s', format(sig.limit))) 
    else
      return(roundr(x, digits = digits))
  }, sig.limit = sig.limit, simplify = FALSE)
}