R/dstudy.R

In talbano/epmr: Tools for Educational and Psychological Measurement

#' Descriptive Study
#'
#' Functions for obtaining descriptive statistics for a vector or matrix
#' of quantitative variables.
#'
#' @param x vector, matrix, or data.frame of scores with one column
#' per variable.
#' @param complete logical with default \code{TRUE} indicating whether or not
#' \code{x} should be reduced to rows with complete data across all columns.
#' @param na.rm logical with default \code{FALSE} specifying whether missings
#' should be removed before calculating individual descriptives.
#' @param ... further arguments passed to or from other functions.
#' @return \code{dstudy} returns a data frame of descriptive statistics, including
#' the mean, median, standard deviation, skewness, kurtosis, minimum, maximum,
#' number of complete cases, and number of NAs (in columns), by variable
#' (in rows). \code{kurt} and \code{skew} return the kurtosis and skewness.
#' \code{summiss} and \code{sumcomp} count missings and complete cases.
#'
#' @examples
#' dstudy(PISA09[, c("elab", "cstrat", "memor")])
#'
#' @export
dstudy <- function(x, complete = TRUE, na.rm = FALSE, ...) {

  x <- as.data.frame(x)
  if (complete) x <- na.omit(x)
  funs <- c(mean, median, sd, skew, kurt, min, max, sumcomp, summiss)
  funs_labs <- c("mean", "median", "sd", "skew", "kurt", "min", "max", "n", "na")

  out <- array(NA_real_, dim = c(length(x), length(funs)),
    dimnames = list(names(x), funs_labs))
  out[] <- sapply(funs, function(f) sapply(x, f, na.rm = na.rm))

  out <- data.frame(out)
  class(out) <- c("dstudy", "data.frame")
  return(out)
}

#' @export
print.dstudy <- function(x, digits = 3, ...) {
  cat("\nDescriptive Study\n\n")
  print.data.frame(x, digits = digits, ...)
  cat("\n")
}

#' @rdname dstudy
#' @export
kurt <- function (x, na.rm = FALSE) {

  mx <- mean(x, na.rm = na.rm)
  sx <- sd(x, na.rm = na.rm)
  return(sum((x - mx)^4, na.rm = na.rm)/(length(x) * sx^4))
}

#' @rdname dstudy
#' @export
skew <- function(x, na.rm = FALSE) {

  mx <- mean(x, na.rm = na.rm)
  sx <- sd(x, na.rm = na.rm)
  return(sum((x - mx)^3, na.rm = na.rm)/(length(x) * sx^3))
}

#' @rdname dstudy
#' @export
summiss <- function(x, ...) sum(is.na(x))

#' @rdname dstudy
#' @export
sumcomp <- function(x, ...) sum(complete.cases(x))