Nothing
#' @title as.covar
#'
#' @description Changes a dispRity metric to use the covar element from a dispRity object.
#'
#' @param fun a \code{function} to apply to the \code{$covar} element of \code{dispRity}.
#' @param ... any additional arguments to pass to fun.
#' @param VCV logical, whether to use the \code{$VCV} component of the elements in \code{dispRity$covar} (\code{TRUE}; default) or not (\code{FALSE}) (see details).
#' @param loc logical, whether to use the \code{$loc} component of the elements in \code{dispRity$covar} (\code{TRUE}) or not (\code{FALSE}; default) (see details).
#'
#' @details
#' This function effectively transforms the input argument from \code{matrix} (or \code{matrix2}) to \code{matrix = matrix$VCV} and adds a evaluation after the return call to indicate that the function works on a \code{$covar} element.
#' Note that if the function does not have an argument called \code{matrix}, the first argument is estimated as being the one to be transformed (e.g. if the function has its first argument \code{x}, it will transform it to \code{x = x$VCV}).
#'
#' You can toggle between using the \code{$VCV} or the \code{$loc} argument in the \code{$covar} matrix by using either \code{VCV = TRUE, loc = FALSE} (to access only \code{fun(matrix = matrix$VCV, ...)}), \code{VCV = FALSE, loc = TRUE} (to access only \code{matrix = matrix(matrix$loc, nrow = 1), ...}) or \code{VCV = TRUE, loc = TRUE} (to access \code{fun(matrix = matrix$VCV, loc = matrix$loc, ...)}; provided \code{fun} has an extra \code{loc} argument).
#'
#' For \code{between.groups} metrics with \code{matrix} and \code{matrix2} arguments, you can provide multiple logicals for \code{VCV} and \code{loc} to be applied repspectively to \code{matrix} and \code{matrix2}. For example \code{VCV = TRUE} will reinterpret \code{matrix} and \code{matrix2} as \code{matrix$VCV} and \code{matrix2$VCV} but \code{loc = c(TRUE, FALSE)} will only reinterpret \code{matrix} as \code{matrix$loc} (and \code{matrix2} will not be reinterpreted).
#' @examples
#' ## Creating a dispRity
#' data(charadriiformes)
#'
#' ## Creating a dispRity object from the charadriiformes model
#' covar_data <- MCMCglmm.subsets(data = charadriiformes$data,
#' posteriors = charadriiformes$posteriors)
#'
#' ## Get one matrix and one covar matrix
#' one_matrix <- get.matrix(covar_data, subsets = 1)
#' one_covar <- get.covar(covar_data, subsets = 1, n = 1)[[1]][[1]]
#'
#' ## Measure the centroids
#' centroids(one_matrix)
#'
#' ## Measure the centroids on the covar matrix
#' as.covar(centroids)(one_covar)
#' ## Is the same as:
#' centroids(one_covar$VCV)
#'
#' ## Apply the measurement on a dispRity object:
#' ## On the traitspace:
#' summary(dispRity(covar_data, metric = c(sum, centroids)))
#' ## On the covariance matrices:
#' summary(dispRity(covar_data, metric = c(sum, as.covar(centroids))))
#' ## The same but with additional options (centre = 100)
#' summary(dispRity(covar_data,
#' metric = c(sum, as.covar(centroids)),
#' centre = 100))
#'
#' ## Example with the VCV and loc options
#' ## A metric that works with both VCV and loc
#' ## (the sum of the variances minus the distance from the location)
#' sum.var.dist <- function(matrix, loc = rep(0, ncol(matrix))) {
#' ## Get the sum of the diagonal of the matrix
#' sum_diag <- sum(diag(matrix))
#' ## Get the distance between 0 and the loc
#' dist_loc <- dist(matrix(c(rep(0, ncol(matrix)), loc), nrow = 2, byrow = TRUE))[1]
#' ## Return the sum of the diagonal minus the distance
#' return(sum_diag - dist_loc)
#' }
#' ## Changing the $loc on one_covar for the demonstration
#' one_covar$loc <- c(1, 2, 3)
#' ## Metric on the VCV part only
#' as.covar(sum.var.dist, VCV = TRUE, loc = FALSE)(one_covar)
#' ## Metric on the loc part only
#' as.covar(sum.var.dist, VCV = FALSE, loc = TRUE)(one_covar)
#' ## Metric on both parts
#' as.covar(sum.var.dist, VCV = TRUE, loc = TRUE)(one_covar)
#'
#' @seealso \code{\link{dispRity}} \code{\link{MCMCglmm.subsets}}
#'
#' @author Thomas Guillerme
#' @export
as.covar <- function(fun, ..., VCV = TRUE, loc = FALSE) {
## Finding the correct arguments to convert
avail_args <- names(formals(fun))
## Switching cases
if(all(c("matrix", "matrix2") %in% avail_args)) {
## Check VCV and loc as double logicals
if(length(VCV) == 1) {
VCV <- rep(VCV, 2)
}
if(length(loc) == 1) {
loc <- rep(loc, 2)
}
## Function templates
if(length(unique(VCV)) == 1) {
if(all(VCV)) {
fun.covar2 <- function(matrix, matrix2, ...) {
return(fun(
matrix = matrix$VCV,
matrix2 = matrix2$VCV,
loc = matrix$loc,
loc2 = matrix2$loc,
...))
## This should never be evaluated by the function but only internally
is_covar <- TRUE
}
}
if(all(!VCV)) {
fun.covar2 <- function(matrix, matrix2, ...) {
return(fun(
matrix = matrix$loc,
matrix2 = matrix2$loc,
...))
## This should never be evaluated by the function but only internally
is_covar <- TRUE
}
}
} else {
if(!VCV[1]) {
fun.covar2 <- function(matrix, matrix2, ...) {
return(fun(
matrix2 = matrix2$VCV,
matrix = matrix$loc,
loc2 = matrix2$loc,
...))
## This should never be evaluated by the function but only internally
is_covar <- TRUE
}
}
if(!VCV[2]) {
fun.covar2 <- function(matrix, matrix2, ...) {
return(fun(
matrix = matrix$VCV,
loc = matrix$loc,
matrix2 = matrix2$loc,
...))
## This should never be evaluated by the function but only internally
is_covar <- TRUE
}
}
}
## Removing the extra arguments (loc or VCV)
if(!VCV[1]) {
body(fun.covar2)[2][[1]][[2]][which(as.character(body(fun.covar2)[2][[1]][[2]]) == "matrix$VCV")] <- NULL
}
if(!VCV[2]) {
body(fun.covar2)[2][[1]][[2]][which(as.character(body(fun.covar2)[2][[1]][[2]]) == "matrix2$VCV")] <- NULL
}
if(!loc[1]) {
body(fun.covar2)[2][[1]][[2]][which(as.character(body(fun.covar2)[2][[1]][[2]]) == "matrix$loc")] <- NULL
}
if(!loc[2]) {
body(fun.covar2)[2][[1]][[2]][which(as.character(body(fun.covar2)[2][[1]][[2]]) == "matrix2$loc")] <- NULL
}
return(fun.covar2)
} else {
## Toggle between the VCV loc options
if(VCV && !loc) {
fun.covar <- function(matrix, ...) {
return(fun(matrix = matrix$VCV, ...))
## This should never be evaluated by the function but only internally
is_covar <- TRUE
}
}
if(!VCV && loc) {
fun.covar<- function(matrix, ...) {
return(fun(matrix = matrix(matrix$loc, nrow = 1), ...))
## This should never be evaluated by the function but only internally
is_covar <- TRUE
}
}
if(VCV && loc) {
fun.covar <- function(matrix, ...) {
return(fun(matrix = matrix$VCV, loc = matrix$loc, ...))
## This should never be evaluated by the function but only internally
is_covar <- TRUE
}
}
if(!is.null(avail_args) && avail_args[1] != "matrix") {
## Change the first argument
names(formals(fun.covar))[1] <- eval(substitute(noquote(avail_args[1])))
## Change the argument name in the body
fun_body <- deparse(body(fun.covar))
## Toggle between the VCV/loc options
if(VCV && !loc) {
new_fun <- paste0(c(fun_body[1], paste0(" return(fun(", avail_args[1], " = ", avail_args[1], "$VCV, ...))"), fun_body[3:4]), collapse="\n")
}
if(!VCV && loc) {
new_fun <- paste0(c(fun_body[1], paste0(" return(fun(", avail_args[1], " = matrix(", avail_args[1], "$loc, nrow = 1), ...))"), fun_body[3:4]), collapse="\n")
}
if(VCV && loc) {
new_fun <- paste0(c(fun_body[1], paste0(" return(fun(", avail_args[1], " = ", avail_args[1], "$VCV, loc = ", avail_args[1], "$loc, ...))"), fun_body[3:4]), collapse="\n")
}
body(fun.covar) <- as.expression(parse(text = new_fun))
}
return(fun.covar)
}
}
# ## Testing in dispRity
# test <- as.covar(variances)
# is_covar <- NULL
# cov_var <- as.covar(variances)
# try(eval(body(variances)[[length(body(variances))]]), silent = TRUE)
# is_covar # NULL
# try(eval(body(cov_var)[[length(body(cov_var))]]), silent = TRUE)
# is_covar # TRUE
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.