Compute statistics for a vector with renaming

dostats.R

library(plyr)
library(stringr)
#' Convenient interface for computing statistics on a vector
#'  @author Andrew Redd
#'
#'  @param x the vector
#'  @param ... statistics to compute, must take a vector and return a vector
#'  @param .na.action the action to take on NA values, for all statistics
#'
#'  @return A one row \code{data.frame} with columns named as in \code{...}
#'  @seealso \code{\link[plyr]{ldply}}
#'  @example ex_dostats.R
dostats <- function(x, ..., .na.action=na.fail){
  if(any(is.na(x)))
    x <- .na.action(x)
  funs   <- list(...)
  fnames <- names(funs)
  { # infer names
    names <- str_sub(deparse(substitute(c(...))), 3, -1)
    names <- str_split(names, ", ")[[1]]
    names <- gsub("^([\\w\\._]+).*", "\\1",  names, perl=T)
  }
  if(is.null(fnames))
    fnames <- names
  else
    fnames <- ifelse(fnames != "", fnames, names)
  l <- structure(llply(funs, do.call, list(x)), names=names)
  l <- llply(l, function(y)if(length(y)==1) y else t(y))
  do.call(data.frame, l)
}

#' Filter by class
#' @param x vector of any class
#' @param .class string for class to filter by
#' @param ... passed to \code{\link{dostats}}
#' @return data frame of computed statistics if x is of class \code{.class}
#'         otherwise returns \code{NULL}.
#' @sealso \code{\link{dostats}}
class.stats <- function(.class){
  if(class(.class)!="character")
    .class=as.character(substitute(.class))
  function(x, ...){if(inherits(x, .class))
    dostats(x, ...)
  else NULL
  }
}
numeric.stats <- class.stats(numeric)
factor.stats  <- class.stats(factor)
integer.stats <- class.stats(integer)

ex_dostats.R

source("dostats.R")
iqr <- function(x){
  structure(diff(quantile(x, c(.25, .75))), names=NULL)
}
dostats(1:10, mean, median, sd, quantile, iqr)
ldply(mtcars, dostats, median, mean, sd, quantile, iqr)