R/proportions.R

In jmbarbone/qpm: Quantitative Psychological Methods

#' Proportions
#'
#' Calculates a proportion from a vector or data frame/matrix.
#'
#' @details
#' tapply(x, x, length) / length(x) can be speedier for smaller data sets and groups
#'   but slows down with more data or a greater number of groups.
#'
#' @param x A data.frame or a vector.
#' @param ... Additional arguments to be passed to methods.
#'
#' @examples
#' proportion(iris, "Species")
#' proportion(iris$Species)
#'
#'\dontrun{
# microbenchmark::microbenchmark(
#'  tapply = prop_tapply(iris, "Sepal.Length"),
#'  proportion = proportion(iris, "Sepal.Length"),
#'  times = 100
#')
#'
#' x <- dplyr::sample_n(iris, 1e6, TRUE)
#'microbenchmark::microbenchmark(
#'  tapply = prop_tapply(x, "Sepal.Length"),
#'  proportion = proportion(x, "Sepal.Length"),
#'  times = 10
#')}
#' @export

proportion <- function(x, ...) {
  UseMethod("proportion", x)
}

#' @export
proportion.default <- function(x, ...) {
  gr <- unique(x)
  res <- vapply(gr, function(.x) mean(.x == x), double(1))
  names(res) <- gr
  res
}

#' @export
proportion.data.frame <- function(x, col, ...) {
  vals <- x[[col]]
  col_name <- col

  groups <- unique(vals)

  res <- data.frame(
    col_name = groups,
    props = vapply(groups, function(.x) mean(.x == vals), double(1))
  )

  names(res)[1] <- col_name
  res
}

#' @export
#' @rdname proportion
prop_tapply <- function(x, ...) {
  UseMethod("prop_tapply", x)
}

#' @export
#' @rdname proportion
prop_tapply.default <- function(x, ...) {
  tapply(x, x, length) / length(x)
}

#' @export
#' @rdname proportion
prop_tapply.data.frame <- function(x, col, ...){
  tapply(x[,col], x[,col], length) / nrow(x)
}