-
Notifications
You must be signed in to change notification settings - Fork 12
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Merge pull request #130 from TGuillerme/BAT.fun
Non BAT related functions pull
- Loading branch information
Showing
14 changed files
with
671 additions
and
57 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,124 @@ | ||
| # #' @title Using metrics from the BAT package. | ||
| # #' | ||
| # #' @description An interface to use metrics from the \code{BAT} package in \code{dispRity} | ||
| # #' | ||
| # #' @param matrix A data matrix or a \code{BAT} structure data list (containing \code{"comm"}, \code{"tree"}, \code{"traits"}). | ||
| # #' @param BAT.fun The name of the metric or directly it's function. | ||
| # #' @param BAT.args Any named optional arguments to be passed to \code{BAT.metric} (default is \code{NULL}) | ||
| # #' @param return.all Whether to return the raw BAT results (\code{TRUE}) or not (\code{FALSE}; default) | ||
| # #' | ||
| # #' @details | ||
| # #' This function is an interface between the \code{dispRity} and B\code{BAT}AT package allowing to use a \code{BAT} function in the \code{dispRity} pipeline. | ||
| # #' By default the function uses the \code{dispRity.metric} format: | ||
| # #' | ||
| # #' \code{metric_value <- BAT.metric(matrix, BAT.fun = BAT::alpha)} | ||
| # #' | ||
| # #' or | ||
| # #' | ||
| # #' \code{metric_value <- BAT.metric(matrix, BAT.fun = "alpha")} | ||
| # #' | ||
| # #' or | ||
| # #' | ||
| # #' \code{metric_value <- BAT.metric(matrix, BAT.fun = alpha)} | ||
| # #' | ||
| # #' With any optional argument being handled normally through \code{BAT.args}. | ||
| # #' | ||
| # #' However, most commonly, the function can be used in the context of the \code{dispRity} pipeline as follows: | ||
| # #' | ||
| # #' \code{my_disparity <- dispRity(my_data, metric = BAT.metric, BAT.fun = BAT::alpha)} | ||
| # #' | ||
| # #' \emph{NOTE} that if the \code{dispRity} object contains a \code{$tree} element. It is recycled to the BAT metric if available as an optional argument. | ||
| # #' You can override this behaviour by providing your own tree (e.g. using \code{BAT.args = list(tree = my_tree)}) or by removing the tree from your input data (e.g. using \code{remove.tree(my_data)}). | ||
| # #' | ||
| # #' @examples | ||
| # #' ## Base example: | ||
| # #' ## Generating a matrix | ||
| # #' dummy_matrix <- matrix(rnorm(90), 9, 10) | ||
| # #' | ||
| # #' ## Applying a BAT metric to it | ||
| # #' alpha_diversity <- BAT.metric(dummy_matrix, BAT.fun = "alpha") | ||
| # #' | ||
| # #' ## dispRity example: | ||
| # #' ## Load ecological data | ||
| # #' data(demo_data) | ||
| # #' eco_data <- demo_data$jones | ||
| # #' ## Subseted data based on two groups | ||
| # #' eco_data | ||
| # #' ## Apply the alpha diversity on these subsets | ||
| # #' alpha_diversity <- dispRity(eco_data, metric = BAT.metric, BAT.fun = "alpha") | ||
| # #' summary(alpha_diversity) | ||
| # #' | ||
| # #' @seealso \code{\link{dispRity}}, \code{\link{custom.subsets}} | ||
| # #' | ||
| # #' @author Thomas Guillerme | ||
| # BAT.metric <- function(matrix, BAT.fun, BAT.args = NULL, return.raw = FALSE) { | ||
|
|
||
| # #SANITIZNG | ||
| # match_call <- match.call() | ||
|
|
||
| # ## Checking the matrix | ||
| # input_comm <- check.class(matrix, c("matrix", "list")) | ||
| # input_is_comm <- FALSE | ||
| # if(input_comm == "list") { | ||
| # if(!all(names(matrix) %in% c("comm", "tree", "traits"))) { | ||
| # stop.call(call = match_call$matrix, msg = " must be a matrix or a named list containing elements 'comm', 'tree' and 'traits'. You can use the function dispRity.BAT() to format it correctly.") | ||
| # } | ||
| # input_is_comm <- TRUE | ||
| # } | ||
|
|
||
| # ## Checking the fun | ||
| # BAT.fun_class <- check.class(BAT.fun, c("function", "character")) | ||
| # if(BAT.fun_class == "function") { | ||
| # ## Check if the function arguments look like BATlike | ||
| # if(!("comm" %in% names(formals(BAT.fun)))) { | ||
| # stop.call(msg.pre = "The function ", call = match_call$BAT.fun, msg = " doesn't look like it's formatted in the BAT style (missing the \"comm\" argument).") | ||
| # } | ||
| # } else { | ||
| # ## Use the implemented functions | ||
| # recognised_function_names <- c("alpha") | ||
| # ## Check if the method exist and is unambiguous | ||
| # check.method(BAT.fun, all_arguments = recognised_function_names, msg = "BAT.fun must be a function or") | ||
| # ## Replace the method | ||
| # BAT.fun <- eval(str2lang(paste0("BAT::", BAT.fun))) | ||
| # } | ||
|
|
||
| # ## Check if the function needs a tree | ||
| # has_BAT_tree_args <- any(names(formals(BAT.fun)) == "tree") | ||
| # has_BAT_trait_args <- any(names(formals(BAT.fun)) == "traits") | ||
|
|
||
| # ## Handle the comms arg | ||
| # comm_arg <- NULL | ||
| # ## Basic | ||
| # if(!input_is_comm) { | ||
| # comm_arg <- make.BAT.comm(matrix) | ||
| # } else { | ||
| # comm_arg <- matrix$comm | ||
| # } | ||
|
|
||
| # ## Handle the arguments | ||
| # if(!is.null(BAT.args)) { | ||
| # BAT_args <- BAT.args | ||
| # } else { | ||
| # BAT_args <- list() | ||
| # } | ||
|
|
||
| # ## Add the comm argument | ||
| # BAT_args$comm <- comm_arg | ||
|
|
||
| # ## Add the tree or traits (if not overriden by ...) | ||
| # if(has_BAT_tree_args && !("tree" %in% names(BAT_args)) && input_is_comm) { | ||
| # BAT_args$tree <- matrix$tree | ||
| # } | ||
| # if(has_BAT_trait_args && !("traits" %in% names(BAT_args)) && input_is_comm) { | ||
| # BAT_args$traits <- matrix$traits | ||
| # } | ||
|
|
||
| # ## Run the fun! | ||
| # if(return.raw) { | ||
| # return(do.call(BAT.fun, BAT_args)) | ||
| # } else { | ||
| # return(do.call(BAT.fun, BAT_args)[[1]]) | ||
| # } | ||
| # } | ||
|
|
||
|
|
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,164 @@ | ||
| # #' @title Converts \code{dispRity} to \code{BAT}. | ||
| # #' | ||
| # #' @description Converts a \code{dispRity} object into \code{BAT} package arguments. | ||
| # #' | ||
| # #' @param data A \code{matrix}, \code{data.frame} or \code{dispRity} object. | ||
| # #' @param subsets Optional, some specific subsets to extract (see \code{\link{get.subsets}}). | ||
| # #' @param matrix Optional, some specific matrices to extract (see \code{\link{get.matrix}}). | ||
| # #' @param tree Optional, some specific trees to extract (see \code{\link{get.tree}}). | ||
| # #' @param inc.all logical, whether to also add a group containing all elements (\code{TRUE}) or not (\code{FALSE}; default). | ||
| # #' | ||
| # #' @details | ||
| # #' Converts the content of a \code{dispRity} object into a list of arguments that can be used by \code{BAT} functions. | ||
| # #' | ||
| # #' @return | ||
| # #' \itemize{ | ||
| # #' \item \code{comm}: a \code{matrix} of presence/absence (\code{0, 1}) sorting the subsets by rows and the elements by columns that can be passed as the \code{comm} argument to \code{BAT} functions. If the \code{data} contains no subsets, the matrix is matrix full of 1 with one row and a number of columns corresponding to the number of elements in \code{data}. If \code{inc.all = TRUE} and \code{data} does not contain a subset with all data, an additional subset with all data is used. | ||
| # #' \item \code{traits}: a \code{matrix} that is the traitspace with elements as rows and dimensions as columns. | ||
| # #' \item \code{tree}: either \code{NULL} if the \code{data} contains no tree or a \code{phylo} or \code{multiPhylo} object from \code{data}. | ||
| # #' } | ||
| # #' | ||
| # #' @examples | ||
| # #' ## Basic example | ||
| # #' data(demo_data) | ||
| # #' BAT_data <- dispRity.BAT(demo_data$jones) | ||
| # #' ## The community table | ||
| # #' BAT_data$comm | ||
| # #' | ||
| # #' ## Complex example | ||
| # #' data(disparity) | ||
| # #' ## The community table for complex data | ||
| # #' ## (including 100 bootstraps for 4 rarefaction levels for 7 subsets | ||
| # #' ## plus the 7 raw subsets for 99 elements = 2807*99) | ||
| # #' dim(dispRity.BAT(disparity)$comm) | ||
| # #' | ||
| # ## Converts a dispRity object into BAT arguments | ||
| # dispRity.BAT <- function(data, subsets, matrix, tree, inc.all = FALSE) { | ||
|
|
||
| # ## Check if data is dispRity | ||
| # check.class(data, "dispRity") | ||
| # ## Check if is subseted | ||
| # is_subseted <- length(data$subsets) != 0 | ||
| # ## If so check if probabilistic | ||
| # is_proba <- FALSE | ||
| # if(is_subseted) { | ||
| # is_proba <- !is.na(data$call$subsets[2]) && grepl("split", data$call$subsets[2]) | ||
| # } | ||
|
|
||
| # ## Placeholders | ||
| # comm <- tree <- traits <- NULL | ||
|
|
||
| # ## Check if matrix exists | ||
| # if(!missing(matrix)) { | ||
| # matrix <- get.matrix(data, matrix = matrix) | ||
| # } else { | ||
| # matrix <- data$matrix[[1]] | ||
| # } | ||
|
|
||
| # ## Check if the data has subsets | ||
| # if(is_subseted) { | ||
| # ## Use subsets if not missing | ||
| # if(!missing(subsets)) { | ||
| # data <- get.subsets(data, subsets) | ||
| # } | ||
|
|
||
| # ## Populate the comms table | ||
| # comm <- do.call(rbind, unlist(lapply(data$subsets, lapply, make.a.subset.comm, matrix = matrix, is_proba = is_proba), recursive = FALSE)) | ||
|
|
||
| # ## Get the table elements | ||
| # subset_names <- name.subsets(data) | ||
|
|
||
| # ## If table had only elements name them as the subsets | ||
| # if(nrow(comm) == length(subset_names)) { | ||
| # rownames(comm) <- subset_names | ||
| # } else { | ||
| # ## Specify the bootstraps and rarefactions | ||
| # names <- lapply(data$subsets, lapply, get.comm.names, matrix = matrix) | ||
| # rownames <- character() | ||
| # for(one_group in 1:length(names)) { | ||
| # rownames <- c(rownames, paste0(subset_names[one_group], ".", unname(unlist(names[[one_group]])))) | ||
| # } | ||
| # rownames(comm) <- rownames | ||
| # } | ||
| # ## Inc all if no entire subset is in the data | ||
| # if(inc.all && !any(apply(comm, 1, function(x) all(x == 1)))) { | ||
| # comm <- rbind(comm, matrix(1, nrow = 1, ncol = nrow(matrix))) | ||
| # rownames(comm)[nrow(comm)] <- "all" | ||
| # } | ||
| # } else { | ||
| # ## No subsets | ||
| # comm <- matrix(1, nrow = 1, ncol = nrow(matrix)) | ||
| # } | ||
| # colnames(comm) <- rownames(matrix) | ||
|
|
||
| # ## Check if the tree exist | ||
| # if(!is.null(data$tree[[1]])) { | ||
| # if(!missing(tree)) { | ||
| # if(missing(subsets)) { | ||
| # subsets <- FALSE | ||
| # } | ||
| # ## Get the tree | ||
| # tree <- get.tree(data, subsets = subsets) | ||
| # ## If the tree is multiPhylo get the first one + warning | ||
| # if(is(tree, "multiPhylo")) { | ||
| # tree <- tree[[1]] | ||
| # warning("data contained a distribution of tree. Only the first tree is used.") | ||
| # } | ||
| # } | ||
| # } | ||
|
|
||
| # ## Return everything | ||
| # return(list(comm = comm, | ||
| # tree = tree, | ||
| # traits = matrix)) | ||
| # } | ||
|
|
||
| # ## Transforms the trait matrix into a community one | ||
| # make.BAT.comm <- function(matrix, data) { | ||
| # if(missing(data)) { | ||
| # return(matrix(1, nrow = 1, ncol = nrow(matrix))) | ||
| # } else { | ||
| # return(matrix(as.integer(rownames(data) %in% rownames(matrix)), nrow = 1, ncol = nrow(data))) | ||
| # } | ||
| # } | ||
|
|
||
| # ## Collapse a bootstrap probability | ||
| # collapse.proba <- function(proba_table) { | ||
| # ## Empty collapse table | ||
| # collapsed_matrix <- matrix(nrow = nrow(proba_table), ncol = 0) | ||
| # ## Collapse the probabilities | ||
| # while(ncol(proba_table) >= 3 && ((ncol(proba_table) %% 3) == 0)) { | ||
| # sub_table <- proba_table[, 1:3] | ||
| # collapsed_matrix <- cbind(collapsed_matrix, apply(sub_table, 1, function(x) sample(x[c(1,2)], size = 1, prob = c(x[3], 1-x[3])))) | ||
| # proba_table <- proba_table[, -c(1:3), drop = FALSE] | ||
| # } | ||
| # return(collapsed_matrix) | ||
| # } | ||
|
|
||
| # ## Make a comm row out of a subset | ||
| # make.a.subset.comm <- function(one_subset, matrix, is_proba = FALSE) { | ||
| # ## Get the elements | ||
| # if(is_proba) { | ||
| # elements <- collapse.proba(one_subset) | ||
| # } else { | ||
| # elements <- one_subset[,, drop = FALSE] | ||
| # } | ||
|
|
||
| # ## Empty community matrix | ||
| # comm_subset <- matrix(0, ncol = ncol(elements), nrow = nrow(matrix)) | ||
|
|
||
| # ## Fill the community matrix | ||
| # for(i in 1:ncol(comm_subset)) { | ||
| # comm_subset[elements[,i],i] <- 1 | ||
| # } | ||
| # return(t(comm_subset)) | ||
| # } | ||
| # ## Get the comm names (bootstraps or rarefactions) | ||
| # get.comm.names <- function(one_subset, matrix) { | ||
| # if(ncol(one_subset) == 1) { | ||
| # return("elements") | ||
| # } else { | ||
| # return(paste0("bootstrap.", nrow(one_subset), ".", 1:ncol(one_subset))) | ||
| # } | ||
| # } | ||
|
|
Oops, something went wrong.