Merge pull request #128 from TGuillerme/ace.continuous

`multi.ace` works for continuous data

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.2
-Date: 2024-01-15
+Version: 1.8.3
+Date: 2024-01-18
 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),

NEWS.md

@@ -1,9 +1,13 @@
-dispRity v1.8.2 (2024-01-15) 
+dispRity v1.8.3 (2024-01-24) 
 =========================
 
+### 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.
+
 ### MINOR IMPROVEMENTS
 
- * `custom.subsets` can now take a logical vector for 
+ * `custom.subsets` can now take a logical vector for the `group` argument.
+ * `plot` functions doing scatter plot now centers them without changing the scale of both axes.
 
 ### BUG FIXES
 

R/MCMCglmm.utilities.R

@@ -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/char.diff.R

@@ -124,7 +124,7 @@ char.diff <- function(matrix, method = "hamming", translate = TRUE, special.toke
     if(matrix_class == "list") {
         ## Check length
         if(length(matrix) != 2) {
-            stop(paste0("When matrix argument is a list, it must contain only two elements.\nYou can convert ", as.expression(match_call$matrix), " to a matrix using:\n", as.expression(match_call$matrix), " <- do.call(rbind, ", as.expression(match_call$matrix), ")"))
+            stop(paste0("When matrix argument is a list, it must contain only two elements.\nYou can convert ", as.expression(match_call$matrix), " to a matrix using:\n", as.expression(match_call$matrix), " <- do.call(rbind, ", as.expression(match_call$matrix), ")"), call. = FALSE)
         }
 
         ## Convert into a matrix
@@ -141,7 +141,7 @@ char.diff <- function(matrix, method = "hamming", translate = TRUE, special.toke
     ## Checking for the reserved character
     reserved <- grep("\\@", matrix)
     if(length(reserved) > 0) {
-        stop("The matrix cannot contain the character '@' since it is reserved for the dispRity::char.diff function.")
+        stop("The matrix cannot contain the character '@' since it is reserved for the dispRity::char.diff function.", call. = FALSE)
     }
 
     ## Method is hamming by default
@@ -174,12 +174,12 @@ char.diff <- function(matrix, method = "hamming", translate = TRUE, special.toke
     ## Checking for the reserved character
     reserved <- c("\\@", "@") %in% special.tokens
     if(any(reserved)) {
-        stop("special.tokens cannot contain the character '@' since it is reserved for the dispRity::char.diff function.")
+        stop("special.tokens cannot contain the character '@' since it is reserved for the dispRity::char.diff function.", call. = FALSE)
     }
 
     ## Checking whether the special.tokens are unique
     if(length(unique(special.tokens)) != length(special.tokens)) {
-        stop("special.tokens cannot contain duplicated tokens.")
+        stop("special.tokens cannot contain duplicated tokens.", call. = FALSE)
     }
 
     ## If any special token is NA, convert them as "N.A" temporarily
@@ -221,7 +221,7 @@ char.diff <- function(matrix, method = "hamming", translate = TRUE, special.toke
         check.class(correction, "function")
         test_correction <- make.metric(correction, silent = TRUE)$type
         if(!is.null(test_correction) && test_correction == "error") {
-            stop("Incorrect correction function.")
+            stop("Incorrect correction function.", call. = FALSE)
         }
     }
 

R/chrono.subsets.R

@@ -445,7 +445,7 @@ chrono.subsets <- function(data, tree = NULL, method, time, model, inc.nodes = F
         check.class(bind.data, "logical")
     } else {
         if(bind.data) {
-            stop(paste0("Impossible to bind the data to the trees since the number of matrices (", length(data), ") is not equal to the number of trees (", length(tree), ")."))
+            stop(paste0("Impossible to bind the data to the trees since the number of matrices (", length(data), ") is not equal to the number of trees (", length(tree), ")."), call. = FALSE)
         }
     }
 

R/chrono.subsets_fun.R

@@ -6,7 +6,7 @@ get.percent.age <- function(tree, percent = 0.01) {
         percent <- percent + 0.01
         tree_slice <- slice.tree.sharp(tree, tree$root.time - (percent * tree$root.time))
         if(percent >= 100) {
-            stop("Impossible to find a starting point to slice the tree. This can happen if the tree has no branch length or has a \"ladder\" structure. You can try to fix that by setting specific slicing times.")
+            stop("Impossible to find a starting point to slice the tree. This can happen if the tree has no branch length or has a \"ladder\" structure. You can try to fix that by setting specific slicing times.", call. = FALSE)
             break
         }
     }

R/dispRity.R

@@ -342,7 +342,7 @@ dispRity <- function(data, metric, dimensions = NULL, ..., between.groups = FALS
         ## Serial is a list, check if it contains the right information (pairs of things that exist)
         pairs <- unique(unlist(lapply(between.groups, length))) 
         if(length(pairs) > 1 || pairs != 2 || max(unlist(between.groups)) > length(data$subsets)) {
-            stop("The provided list of groups (between.groups) must be a list of pairs of subsets in the data.")
+            stop("The provided list of groups (between.groups) must be a list of pairs of subsets in the data.", call. = FALSE)
         }
         list_of_pairs <- between.groups
         is_between.groups <- TRUE

R/dispRity.metric.R

@@ -1116,7 +1116,7 @@ projections.tree <- function(matrix, tree, type = c("root","ancestor"), referenc
     }
     ## Sanitizing (to avoid obscure error message!)
     if(any(is_null <- unlist(lapply(from_to, is.null)))) {
-        stop(paste0("The following type argument is not recognised in projections.tree: ", paste0(type[is_null], collapse = ", ")))
+        stop(paste0("The following type argument is not recognised in projections.tree: ", paste0(type[is_null], collapse = ", ")), call. = FALSE)
     }
 
     if(all(invariables)) {

R/dispRity.utilities_fun.R

@@ -50,7 +50,7 @@ check.subsets <- function(subsets, data) {
         if(is(subsets, "numeric") || is(subsets, "integer")) {
             if(any(na_subsets <- is.na(match(subsets, 1:length(data$disparity))))) {
                 ## Subsets not found
-                stop(paste0(ifelse(length(which(na_subsets)) > 1, "Subsets ", "Subset "), paste0(subsets[which(na_subsets)], collapse = ", "), " not found."))
+                stop(paste0(ifelse(length(which(na_subsets)) > 1, "Subsets ", "Subset "), paste0(subsets[which(na_subsets)], collapse = ", "), " not found."), call. = FALSE)
             }
         } else {
             if(is(subsets, "character")) {
@@ -61,10 +61,10 @@ check.subsets <- function(subsets, data) {
                 ## Check if the searched ones exist
                 if(any(na_subsets <- is.na(match(subset_search, subset_available)))) {
                     ## Subsets not found
-                    stop(paste0(ifelse(length(which(na_subsets)) > 1, "Subsets ", "Subset "), paste0(subsets[which(na_subsets)], collapse = ", "), " not found."))
+                    stop(paste0(ifelse(length(which(na_subsets)) > 1, "Subsets ", "Subset "), paste0(subsets[which(na_subsets)], collapse = ", "), " not found."), call. = FALSE)
                 }
             } else {
-                stop("subsets argument must be of class \"numeric\" or \"character\".")
+                stop("subsets argument must be of class \"numeric\" or \"character\".", call. = FALSE)
             }
         }
 
@@ -76,24 +76,24 @@ check.subsets <- function(subsets, data) {
         }
 
         if(length(subsets) > length(data$subsets)) {
-            stop("Not enough subsets in the original data.")
+            stop("Not enough subsets in the original data.", call. = FALSE)
         } else {
             if(is(subsets, "numeric") || is(subsets, "integer")) {
                 if(any(na_subsets <- is.na(match(subsets, 1:length(data$subsets))))) {
                     ## Subsets not found
-                    stop(paste0(ifelse(length(which(na_subsets)) > 1, "Subsets ", "Subset "), paste0(subsets[which(na_subsets)], collapse = ", "), " not found."))
+                    stop(paste0(ifelse(length(which(na_subsets)) > 1, "Subsets ", "Subset "), paste0(subsets[which(na_subsets)], collapse = ", "), " not found."), call. = FALSE)
                 }
             } else {
                 if(is(subsets, "character")) {
                     if(any(is.na(match(subsets, names(data$subsets))))) {
 
                         subsets <- subsets[which(is.na(match(subsets, names(data$subsets))))]
                         orthograph <- ifelse(length(subsets) == 1, "Subset ", "Subsets ")
-                        stop(paste0(orthograph, paste0(subsets, collapse = ", "), " not found."))
+                        stop(paste0(orthograph, paste0(subsets, collapse = ", "), " not found."), call. = FALSE)
 
                     }
                 } else {
-                    stop("subsets argument must be of class \"numeric\" or \"character\".")
+                    stop("subsets argument must be of class \"numeric\" or \"character\".", call. = FALSE)
                 }
             }
         }

R/dispRity_fun.R

@@ -268,7 +268,7 @@ decompose.VCV <- function(one_subsets_bootstrap, fun, data, use_array, use_tree
             #fun(data$covar[[one_subsets_bootstrap[1]]][[1]], data$covar[[one_subsets_bootstrap[2]]][[2]])
         }
     } else {
-        stop("Impossible to use tree metric in dispRity with covar (yet!).")
+        stop("Impossible to use tree metric in dispRity with covar (yet!).", call. = FALSE)
     }
 }
 

R/dtt.dispRity_fun.R

@@ -66,7 +66,7 @@ geiger.dtt.dispRity <- function(phy, data, metric, relative){
         ## By array
 
         if(length(dim(td$data)) != 3){
-            stop("Error in data: must be a matrix or a array of matrix (length(dim(data)) must be equal to 2 or 3).")
+            stop("Error in data: must be a matrix or a array of matrix (length(dim(data)) must be equal to 2 or 3).", call. = FALSE)
         }
 
         ## Looping through the array
@@ -161,7 +161,7 @@ geiger.sim.char <- function(phy, par, nsim = 1, model = c("BM", "speciational",
     nbranches<-nrow(phy$edge)
     nspecies<-Ntip(phy)
 
-    if(length(root)>1) stop("'root' should be a single value")
+    if(length(root)>1) stop("'root' should be a single value", call. = FALSE)
 
     if(model%in%c("BM", "speciational")) {
 
@@ -190,7 +190,7 @@ geiger.sim.char <- function(phy, par, nsim = 1, model = c("BM", "speciational",
         }
         for(j in 1:nchar) {
             m=model.matrix[[j]]
-            if(!root%in%c(1:nrow(m))) stop(paste("'root' must be a character state from 1 to ", nrow(m), sep=""))
+            if(!root%in%c(1:nrow(m))) stop(paste("'root' must be a character state from 1 to ", nrow(m), sep=""), call. = FALSE)
             p=lapply(el, function(l) matexpo(m*l))
 
             for(k in 1:nsim) {
@@ -221,16 +221,16 @@ geiger.make.modelmatrix <- function(m, model=c("BM", "speciational", "discrete")
             for(j in 1:length(m)){
                 #.check.Qmatrix
                 m=unique(dim(m[[j]]))
-                if(length(m)>1) stop("'Q' must be a square matrix")
+                if(length(m)>1) stop("'Q' must be a square matrix", call. = FALSE)
                 didx=1 + 0L:(m - 1L) * (m + 1)
-                if(!all(abs(rowSums(m[[j]]))<0.000001)) stop("rows of 'Q' must sum to zero")
-                if(!all(m[[j]][didx]<=0)) stop("diagonal elements of 'Q' should be negative")
-                if(!all(m[[j]][-didx]>=0)) stop("off-diagonal elements of 'Q' should be positive")
+                if(!all(abs(rowSums(m[[j]]))<0.000001)) stop("rows of 'Q' must sum to zero", call. = FALSE)
+                if(!all(m[[j]][didx]<=0)) stop("diagonal elements of 'Q' should be negative", call. = FALSE)
+                if(!all(m[[j]][-didx]>=0)) stop("off-diagonal elements of 'Q' should be positive", call. = FALSE)
             }
         }
     } else {
-        if(is.numeric(m)) m=as.matrix(m) else stop("Supply 'm' as a matrix of rates")
-        if(any(diag(m)<0)) stop("'m' appears to have negative variance component(s)")
+        if(is.numeric(m)) m=as.matrix(m) else stop("Supply 'm' as a matrix of rates", call. = FALSE)
+        if(any(diag(m)<0)) stop("'m' appears to have negative variance component(s)", call. = FALSE)
     }
     return(m)
 }

R/make.metric_fun.R

@@ -11,6 +11,6 @@ check.metric <- function(metric) {
             return("class.metric")
         }
     } else {
-        stop("Invalid metric.")
+        stop("Invalid metric.", call. = FALSE)
     }
 }

R/match.tip.edge.R

@@ -58,7 +58,7 @@ match.tip.edge <- function(vector, phylo, replace.na, use.parsimony = TRUE) {
     ## TODO: check number of nodes as well
     if(length(vector) != Ntip(phylo)[1]) {
         if(length(vector) != Ntip(phylo)[1]+Nnode(phylo)[1]) {
-            stop(paste0("The input vector must of the same length as the number of tips (", Ntip(phylo)[1], ") or tips and nodes (", Ntip(phylo)[1]+Nnode(phylo)[1] ,") in phylo."))
+            stop(paste0("The input vector must of the same length as the number of tips (", Ntip(phylo)[1], ") or tips and nodes (", Ntip(phylo)[1]+Nnode(phylo)[1] ,") in phylo."), call. = FALSE)
         }
     }
     if(length(vector) == Ntip(phylo)[1]+Nnode(phylo)[1]) {