#' Covariance Matrix Calculation for (Potentially Grouped) Data
#'
#' @param x data you would like the covariance matrix of. The parameter \code{x}
#' can be a \code{data.frame}, \code{grouped_df}, \code{resample}, or
#' \code{matrix}.
#' @param ... other options passed to covarince estimation method
#' @param covEst covariance or precision matrix estimation method, as a function.
#' Defaults to \code{stats::cov}.
#'
#' @return list of matries with class \code{covariance} by group. These matrices
#' may be covariance or precision matrices, depending on the function
#' supplied to the \code{covEst} argument.
#'
#' @details This function has the capability to calculate total and group-level
#' covariance and precision matrices estimated from the given data. Specify
#' group membership with the \code{group = "COLNAME"} syntax. Additionally,
#' this function returns objects with an additional class: when this function
#' returns group-level lists of matrices, each covariance or precision matrix
#' will have the \code{R} classes \code{matrix} \emph{and} \code{covariance};
#' likewise, total covariance or precision matrices are also returned with
#' the classes \code{matrix} and \code{covariance}. Moreover, these matrices
#' have an additional named attribute: \code{df}, for \emph{degrees of freedom}.
#' The computational functionality of the \code{covariance} class will be
#' explored in future updates.
#'
#' @export
#'
#' @examples
#' cov(iris[,1:4])
#' cov(iris, group = "Species")
#' cov(iris[,1:4], covEst = Haff_shrinkage)
cov <- function(x, ..., covEst = stats::cov){
UseMethod("cov")
}
#' @export
#' @keywords internal
#' @importFrom dplyr as_data_frame
#' @importFrom stats cov
#' @importFrom stats setNames
#' @importFrom lazyeval lazy_dots
#' @importFrom lazyeval lazy_eval
#' @importFrom lazyeval f_unwrap
cov.data.frame <- function(x, ..., covEst = stats::cov){
dots <- lazy_dots(...)
if("group" %in% names(dots)){
groupname <- names(unique(x[paste(dots$group$expr)]))
group <- as.character(unique(x[[paste(dots$group$expr)]]))
dots <- dots[!("group" %in% names(dots))]
x <- setNames(lapply(group, function(y){
as.matrix(x[x[groupname] == y,][names(x) != groupname])
}), group)
lapply(x, function(y){
mat <- do.call(covEst, c(x = list(y), lazy_eval(dots)))
df <- nrow(y) - 1
atr <- attributes(mat)
attributes(mat) <- c(atr, df = f_unwrap(~ df))
class(mat) <- c("covariance", "matrix")
mat
})
}else{
mat <- do.call(covEst, c(x = list(x), lazy_eval(dots)))
df <- nrow(x) - 1
atr <- attributes(mat)
attributes(mat) <- c(atr, df = f_unwrap(~ df))
class(mat) <- c("covariance", "matrix")
mat
}
}
#' @export
#' @keywords internal
#' @importFrom dplyr as_data_frame
#' @importFrom stats cov
#' @importFrom stats setNames
#' @importFrom lazyeval lazy_dots
#' @importFrom lazyeval lazy_eval
#' @importFrom lazyeval f_unwrap
cov.grouped_df <- function(x, ..., covEst = stats::cov){
groups <- attributes(x)$labels
x <- as_data_frame(x)
group <- as.character(groups[,1])
groupname <- names(groups)
ls <- setNames(lapply(group, function(y){
as.matrix(x[x[groupname] == y,][names(x) != groupname])
}), group)
dots <- lazy_dots(...)
lapply(ls, function(x){
mat <- do.call(covEst, c(x = list(x), lazy_eval(dots)))
df <- nrow(x) - 1
atr <- attributes(mat)
attributes(mat) <- c(atr, df = f_unwrap(~ df))
class(mat) <- c("covariance", "matrix")
mat
})
}
#' @export
#' @keywords internal
#' @importFrom dplyr as_data_frame
#' @importFrom stats cov
#' @importFrom stats setNames
#' @importFrom lazyeval lazy_dots
#' @importFrom lazyeval lazy_eval
#' @importFrom lazyeval f_unwrap
cov.resample <- function(x, ..., covEst = stats::cov){
x <- as_data_frame(x)
groups <- attributes(x)$labels
group <- as.character(groups[,1])
groupname <- names(groups)
ls <- setNames(lapply(group, function(y){
as.matrix(x[x[groupname] == y,][names(x) != groupname])
}), group)
dots <- lazy_dots(...)
lapply(ls, function(x){
mat <- do.call(covEst, c(x = list(x), lazy_eval(dots)))
df <- nrow(x) - 1
atr <- attributes(mat)
attributes(mat) <- c(atr, df = f_unwrap(~ df))
class(mat) <- c("covariance", "matrix")
mat
})
}
#' @export
#' @keywords internal
#'
#' @importFrom stats cov
#' @importFrom lazyeval lazy_dots
#' @importFrom lazyeval lazy_eval
#' @importFrom lazyeval f_unwrap
cov.matrix <- function(x, ..., covEst = stats::cov){
dots <- lazy_dots(...)
mat <- do.call(covEst, c(x = list(x), lazy_eval(dots)))
df <- nrow(x) - 1
atr <- attributes(mat)
attributes(mat) <- c(atr, df = f_unwrap(~ df))
class(mat) <- c("covariance", "matrix")
mat
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.