Merge branch 'master' into release

DESCRIPTION

@@ -7,8 +7,8 @@ Authors@R: c(person("Thomas", "Guillerme", role = c("aut", "cre", "cph"),
   			 person("Jack", "Hatfield",    role = c("aut", "cph"))
   			 )
 Maintainer: Thomas Guillerme <[email protected]>
-Version: 1.8
-Date: 2023-12-11
+Version: 1.9
+Date: 2024-11-12
 Description: A modular package for measuring disparity (multidimensional space occupancy). Disparity can be calculated from any matrix defining a multidimensional space. The package provides a set of implemented metrics to measure properties of the space and allows users to provide and test their own metrics. The package also provides functions for looking at disparity in a serial way (e.g. disparity through time) or per groups as well as visualising the results. Finally, this package provides several statistical tests for disparity analysis.
 Depends:
     R (>= 3.6.0),

NAMESPACE

@@ -56,6 +56,7 @@ export(angles)
 export(centroids)
 export(convhull.volume)
 export(convhull.surface)
+export(count.neighbours)
 export(deviations)
 export(diagonal)
 export(dimension.level1.fun)
@@ -109,6 +110,7 @@ export(get.covar)
 export(n.subsets)
 export(make.dispRity)
 export(name.subsets)
+export(remove.dispRity)
 export(rescale.dispRity) # alias for scale
 export(scale.dispRity)
 export(size.subsets)
@@ -134,6 +136,7 @@ export(distance.randtest)
 export(reduce.matrix)
 export(reduce.space)
 export(remove.zero.brlen)
+export(set.root.time)
 export(slice.tree)
 export(slide.nodes)
 export(space.maker)

NEWS.md

@@ -1,3 +1,37 @@
+dispRity v1.9 (2024-11-12)  *distant update*
+=========================
+
+### NEW FEATURES
+ * Redesigned `multi.ace` to be more modular and handle both continuous and/or discrete characters. Changes include a **change in argument name** from `castor.options` to the generic `options.args` (the options can be provided the same way as before though); and a **change in default arguments** for `models` which can now be left missing (previously was `"ER"`) and applies `"ER"` and `"BM"` for respectively discrete and continuous characters by default.
+ * New design when using distance matrices: `dist.helper` now allows to save distance matrices in the cache, saving a lot of RAM and speeding up calculations. You can use the helper using `dispRity(..., dist.helper = my_distance_function)` or `dispRity(..., dist.helper = my_distance_matrix)`.
+ * *New `dispRity`, `custom.subsets` and `chrono.subsets` option*: these three functions can now use `dist.data = TRUE` to specify that the input data is a distance matrix (and handle it accordingly).
+ * *New bootstrap options*: you can now use `boot.by` to specify whether bootstrap the rows (previous behaviour), the columns or both (for distance matrices).
+ * *New utility function* `set.root.time` to add a root time to a tree (`"phylo"`), list of trees (`"multiPhylo"`) or `dispRity` object with trees.
+ * *New utility function* `remove.dispRity` to cleanly remove specific parts of a `"dispRity"` object.
+ * *New metric*: `count.neighbours` to count the number of neighbours for each elements within a certain radius (thanks to Rob MacDonald for the suggestion).
+
+### MINOR IMPROVEMENTS
+
+ * `custom.subsets` can now take a logical vector for the `group` argument.
+ * `custom.subsets` now recycles node names when using a tree to create clade groups.
+ * `plot` functions doing scatter plot now centers them without changing the scale of both axes.
+ * **changed default argument** for `tree.age`: the number of digits output by `tree.age` is now changed from 3 to 4 by default.
+ * the random starting parameters in `reduce.space` are now drawn from the input data distribution which speeds up the function significantly.
+ * `match.tip.edges` can now just work for colouring edges connecting a vector of tips.
+ * remove deprecated internal requirements in `boot.matrix`.
+ * improved RAM management for `make.metric` (now uses the largest requestable subset rather than the whole data for testing).
+
+### BUG FIXES
+
+ * `scale.dispRity` now correctly ignores `NA`s when scaling.
+ * `multi.ace` now correctly handles invariant characters when looking for NAs.
+ * `dispRity` objects with a `$covar` component are not interpreted as bootstrapped by `boot.matrix` anymore.
+
+### DEPRECATED
+
+ * The `dimensions` argument from `boot.matrix` is now removed: it has been redundant with the `dimensions` argument in the `dispRity` since v0.3!
+
+
 dispRity v1.8 (2023-12-11) *dispRity.multi*
 =========================
 

R/MCMCglmm.subsets.R

@@ -62,13 +62,19 @@ MCMCglmm.subsets <- function(data, posteriors, group, tree, rename.groups, set.l
         if(any(classifier)) {
             group_classifier <- data[,which(!numerics)[which(classifier)], drop = FALSE]
         }
+    } else {
+        cleaned_data <- data
+        group_classifier <- matrix(1, nrow = nrow(data), ncol = 1, dimnames = list(rownames(data)))
     }
 
     ## Checking the posteriors
     check.class(posteriors, "MCMCglmm")
 
     ## Check which dimensions where used
     dimensions <- match(MCMCglmm.traits(posteriors), colnames(cleaned_data))
+    if(all(is.na(dimensions))) {
+        stop.call(msg = "Could not match any column in the data with the posterior samples. Make sure the data column names are the same as the one used in the MCMCglmm.", call = "")
+    }
 
     ## Extracting the residuals and randoms
     posterior_levels <- MCMCglmm.levels(posteriors)

R/MCMCglmm.utilities.R

@@ -49,11 +49,11 @@
 #' MCMCglmm.covars(model, sample = 42)
 #' ## Get two random samples from the model
 #' MCMCglmm.covars(model, n = 2)
-    
-## Get the variance for each terms in the model
-# terms_variance <- MCMCglmm.variance(model)
-# boxplot(terms_variance, horizontal = TRUE)
-
+#'
+#' ## Get the variance for each terms in the model
+#' terms_variance <- MCMCglmm.variance(model)
+#' boxplot(terms_variance, horizontal = TRUE, las = 1)
+#'
 #' @seealso \code{\link{MCMCglmm.subsets}}
 #' 
 #' @author Thomas Guillerme
@@ -193,10 +193,9 @@ MCMCglmm.covars <- function(MCMCglmm, n, sample){
         } else {
             check.class(sample, c("numeric", "integer"))
 
-            ## Check for incorect samples
+            ## Check for incorrect samples
             if(length(incorect_sample <- which(sample > length(MCMCglmm.sample(MCMCglmm)))) > 0) {
-                    #dispRity_export in: MAKE dispRity STOP STYLE
-                    stop("Some samples are not available in the MCMCglmm object.")#dispRity_export out: 
+                stop("Some samples are not available in the MCMCglmm object.", call. = FALSE)
             }
         }
     } else {

R/adonis.dispRity.R

@@ -72,6 +72,8 @@
 #' 
 #' 
 #' @author Thomas Guillerme
+#' @references Oksanen J, Simpson G, Blanchet F, Kindt R, Legendre P, Minchin P, O'Hara R, Solymos P, Stevens M, Szoecs E, Wagner H, Barbour M, Bedward M, Bolker B, Borcard D, Carvalho G, Chirico M, De Caceres M, Durand S, Evangelista H, FitzJohn R, Friendly M, Furneaux B, Hannigan G, Hill M, Lahti L, McGlinn D, Ouellette M, Ribeiro Cunha E, Smith T, Stier A, Ter Braak C, Weedon J (2024). vegan: Community Ecology Package_. R package version 2.6-8,
+
 # @export
 
 # source("sanitizing.R")
@@ -218,8 +220,8 @@ adonis.dispRity <- function(data, formula = matrix ~ group, method = "euclidean"
 
     ## Run adonis
     ## Modifying adonis2 to only check the parent environment (not the global one: matrix input here should be present in the environment
-    adonis2.modif <- vegan::adonis2
-    formals(adonis2.modif) <-c(formals(vegan::adonis2), "matrix_input" = NA)
+    adonis2.modif <- adonis2
+    formals(adonis2.modif) <-c(formals(adonis2), "matrix_input" = NA)
     body(adonis2.modif)[[5]] <- substitute(lhs <- matrix_input)
     adonis_out <- adonis2.modif(formula, predictors, method = method, matrix_input = matrix, ...)
     # adonis_out <- adonis2.modif(formula, predictors, method = method, matrix_input = matrix) ; warning("DEBUG adonis.dispRity")

R/as.covar.R

@@ -88,63 +88,63 @@ as.covar <- function(fun, ..., VCV = TRUE, loc = FALSE) {
         if(length(unique(VCV)) == 1) {  
             if(all(VCV)) {
                 fun.covar2 <- function(matrix, matrix2, ...) {
+                    ## This should never be evaluated by the function but only internally
+                    fun_is_covar <-TRUE
                     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, ...) {
+                    ## This should never be evaluated by the function but only internally
+                    fun_is_covar <-TRUE
                     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, ...) {
+                    ## This should never be evaluated by the function but only internally
+                    fun_is_covar <-TRUE
                     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, ...) {
+                    ## This should never be evaluated by the function but only internally
+                    fun_is_covar <-TRUE
                     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
+            body(fun.covar2)[3][[1]][[2]][which(as.character(body(fun.covar2)[3][[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
+            body(fun.covar2)[3][[1]][[2]][which(as.character(body(fun.covar2)[3][[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
+            body(fun.covar2)[3][[1]][[2]][which(as.character(body(fun.covar2)[3][[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
+            body(fun.covar2)[3][[1]][[2]][which(as.character(body(fun.covar2)[3][[1]][[2]]) == "matrix2$loc")] <- NULL
         }
 
         return(fun.covar2)
@@ -154,23 +154,23 @@ as.covar <- function(fun, ..., VCV = TRUE, loc = FALSE) {
         ## 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
+                fun_is_covar <-TRUE
+                return(fun(matrix = matrix$VCV, ...))
             }
         }
         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
+                fun_is_covar <-TRUE
+                return(fun(matrix = matrix(matrix$loc, nrow = 1), ...))
             }
         }
         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
+                fun_is_covar <-TRUE
+                return(fun(matrix = matrix$VCV, loc = matrix$loc, ...))
             }
         }
 
@@ -184,15 +184,17 @@ as.covar <- function(fun, ..., VCV = TRUE, loc = FALSE) {
 
             ## 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")
+                new_fun <- paste0(c(fun_body[1:2], paste0("    return(fun(", avail_args[1], " = ", avail_args[1], "$VCV, ...))"), fun_body[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")
+                new_fun <- paste0(c(fun_body[1:2], paste0("    return(fun(", avail_args[1], " = matrix(", avail_args[1], "$loc, nrow = 1), ...))"), fun_body[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")
+                new_fun <- paste0(c(fun_body[1:2], paste0("    return(fun(", avail_args[1], " = ", avail_args[1], "$VCV, loc = ", avail_args[1], "$loc, ...))"), fun_body[4]), collapse="\n")
             }
 
+            # message(new_fun)
+
             body(fun.covar) <- as.expression(parse(text = new_fun))
         }
 
@@ -203,7 +205,7 @@ as.covar <- function(fun, ..., VCV = TRUE, loc = FALSE) {
 
 # ## Testing in dispRity
 # test <- as.covar(variances)
-# is_covar <- NULL
+# fun_is_covar <-NULL
 # cov_var <- as.covar(variances)
 
 # try(eval(body(variances)[[length(body(variances))]]), silent = TRUE)

R/as.covar_fun.R

@@ -1,8 +1,14 @@
 ## Cleanly evalute the covarness of a function
 eval.covar <- function(fun, null.return = NULL) {
-    is_covar <- FALSE
+    fun_is_covar <- FALSE
     if(!is.null(fun)) {
-        return(all(c("is_covar", "TRUE") %in% as.character(body(fun)[[length(body(fun))]])))
+        ## Check if it can evaluate covar
+        if(length(grep("fun_is_covar", as.character(body(fun)))) > 0) {
+            ## evaluate the fun_is_covar variable 
+            eval(body(fun)[[2]])
+        } 
+        # return(all(c("fun_is_covar", "TRUE") %in% as.character(body(fun)[[2]])))
+        return(fun_is_covar)
     } else {
         return(null.return)
     }