roundness metric added

NAMESPACE

@@ -78,6 +78,7 @@ export(projections.tree)
 export(quantiles)
 export(radius)
 export(ranges)
+export(roundness)
 export(span.tree.length)
 export(variances)
 

NEWS.md

@@ -3,37 +3,26 @@ dispRity v1.7.16 (2023-11-17) *dispRity.multi*
 
 <!-- TODO: route to 1.8 (and that's it for this one)-->
 <!--
- - [ ] add roundness metric
-    - [ ] test
-    - [ ] doc
-    - [ ] example
-    - [ ] manual
+ - [x] add roundness metric
+    - [x] test
+    - [x] doc
+    - [x] example
+    - [x] manual
  - [ ] add `get.tree` working for subsets
     - [x] test
     - [ ] doc
     - [ ] example
     - [ ] manual
- - [ ] make `dispRity` and al. `dispRitreatable` (Mario's suggestion)
+ - [x] make `dispRity` and al. `dispRitreatable` (Mario's suggestion)
     - [x] test
-    - [ ] doc
-    - [ ] example
-    - [ ] manual
+    - [x] doc
+    - [x] example
+    - [x] manual
  - [ ] Developers vignette
     - [ ] update code lines numbers Packaging/dispRity.length.R
     - [x] clean repo root
     - [x] remove disparity_object.md
     - [x] remove disparity_internal_logic.md
- - [ ] add text about boot.type = "null" 
-
- -->
- <!-- *New metric*: `roundness` to measure how round the elliptical representation of a matrix is. TODO: handle non-VCV input:
- ## The roundness function
-roundness <- function(matrix) {
-  y <- sort(diag(matrix))
-  y <- y/max(y)
-  x <- seq(from = 0, to = 1, length.out = length(y))
-  sum(diff(x)*zoo::rollmean(y, 2))
-}
  -->
 
 
@@ -45,6 +34,7 @@ roundness <- function(matrix) {
  * *New* statistical test: `pgls.dispRity` to run PGLS test on a `dispRity` object with a level-2 metric and a tree (using excellent [`phylolm`](https://cran.r-project.org/web/packages/phylolm/phylolm.pdf) algorithm). The new test comes with its own S3 print, summary and plot functions if the input `dispRity` data contains multiple trees or multiple matrices (running and handling the output of multiple `phylolm`).
  * *New* options to `get.tree` utility function to get the trees in each subsets (thanks to Jack Hadfield for this suggestion).
  * *New vignette* compiling resources for developers to help people (and future me) to edit the package. 
+ * *New metric*: `roundness` to measure the roundness of a variance-covariance matrix. 
 
 ### MINOR IMPROVEMENTS
 
@@ -67,6 +57,7 @@ roundness <- function(matrix) {
  * Improved automatic centering and scaling for `covar.plot` making the figures more aesthetic.
  * `remove.zero.brlen` now also removes negative branch lengths and works on `"multiPhylo"` objects (thanks to Thomas Johnson for this suggestion).
  * `fill.dispRity` has now an extra argument `check` to toggle the data checking on and off (more for developers).
+ * `multi.ace` is now described in details in the manual.
 
 ### BUG FIXES
 

R/dispRity.metric.R

@@ -1,5 +1,5 @@
 #' @name dispRity.metric
-#' @aliases dimension.level3.fun dimension.level2.fun dimension.level1.fun between.groups.fun variances ranges centroids mode.val ellipse.volume edge.length.tree convhull.surface convhull.volume diagonal ancestral.dist pairwise.dist span.tree.length n.ball.volume radius neighbours displacements quantiles func.eve func.div angles deviations group.dist point.dist projections projections.tree projections.between disalignment
+#' @aliases dimension.level3.fun dimension.level2.fun dimension.level1.fun between.groups.fun variances ranges centroids mode.val ellipse.volume edge.length.tree convhull.surface convhull.volume diagonal ancestral.dist pairwise.dist span.tree.length n.ball.volume radius neighbours displacements quantiles func.eve func.div angles deviations group.dist point.dist projections projections.tree projections.between disalignment roundness
 #' @title Disparity metrics
 #'
 #' @description Different implemented disparity metrics.
@@ -46,6 +46,8 @@
 #'   \item \code{mode.val}: calculates the modal value of a vector.
 #'
 #'   \item \code{n.ball.volume}: calculate the volume of the minimum n-ball (if \code{sphere = TRUE}) or of the ellipsoid (if \code{sphere = FALSE}).
+#'
+#'   \item \code{roundness}: calculate the roundness of an elliptical representation of a variance-covariance matrix as the integral of the ranked distribution of the major axes. A value of 1 indicates a sphere, a value between 1 and 0.5 indicates a more pancake like representation and a value between 0.5 and 0 a more cigar like representation. You can force the variance-covariance calculation by using the option \code{vcv = TRUE} (default) that will calculate the variance-covariance matrix if the input is not one.
 #' 
 #' }
 #' 
@@ -338,6 +340,14 @@
 #' ## ranges of each column in the matrix corrected using the kth root
 #' ranges(dummy_matrix, k.root = TRUE)
 #'
+#' ## roundness
+#' ## calculating the variance-covariance of the dummy_matrix
+#' vcv <- var(dummy_matrix)
+#' ## calculating the roundness of it
+#' roundness(vcv)
+#' ## calculating the roundness of the dummy matrix by calculating the vcv
+#' roundness(dummy_matrix, vcv = TRUE)
+#'
 #' ## span.tree.length
 #' ## Minimum spanning tree length (default)
 #' span.tree.length(dummy_matrix)
@@ -393,6 +403,7 @@ dimension.level1.fun <- function(matrix, ...) {
     cat("\n?group.dist")
     cat("\n?mode.val")
     cat("\n?n.ball.volume")
+    cat("\n?roundness")
 }
 
 between.groups.fun <- function(matrix, matrix2, ...) {
@@ -1113,3 +1124,24 @@ projections.tree <- function(matrix, tree, type = c("root","ancestor"), referenc
     }
 }
 
+
+## The roundness function
+roundness <- function(matrix, vcv = TRUE) {
+    ## Check the vcv
+    if(vcv) {
+        ## Check the dimensions and the triangles
+        if(length(unique(dim(matrix))) == 1 && all(matrix[upper.tri(matrix)] == matrix[rev(lower.tri(matrix))], na.rm = TRUE)) {
+            vcv <- matrix
+        } else {
+            vcv <- var(matrix)
+        }
+    }   
+
+    ## Sort and scale the eigen values
+    y <- sort(diag(matrix))
+    y <- y/max(y)
+    x <- seq(from = 0, to = 1, length.out = length(y))
+    ## Measure the integral
+    return(sum(diff(x)*zoo::rollmean(y, 2)))
+}
+

tests/testthat/test-dispRity.metric.R

@@ -7,7 +7,7 @@ nocov <- TRUE
 test_that("dimension generic", {
     expect_equal(capture_output(dimension.level3.fun()), "No implemented Dimension level 3 functions implemented in dispRity!\nYou can create your own by using: ?make.metric")
     expect_equal(capture_output(dimension.level2.fun()), "Dimension level 2 functions implemented in dispRity:\n?ancestral.dist\n?angles\n?centroids\n?deviations\n?displacements\n?edge.length.tree\n?neighbours\n?pairwise.dist\n?point.dist\n?projections\n?projections.tree\n?ranges\n?radius\n?variances\n?span.tree.length")
-    expect_equal(capture_output(dimension.level1.fun()), "Dimension level 1 functions implemented in dispRity:\n?convhull.surface\n?convhull.volume\n?diagonal\n?ellipse.volume\n?func.div\n?func.eve\n?group.dist\n?mode.val\n?n.ball.volume")
+    expect_equal(capture_output(dimension.level1.fun()), "Dimension level 1 functions implemented in dispRity:\n?convhull.surface\n?convhull.volume\n?diagonal\n?ellipse.volume\n?func.div\n?func.eve\n?group.dist\n?mode.val\n?n.ball.volume\n?roundness")
     expect_equal(capture_output(between.groups.fun()), "Between groups functions implemented in dispRity:\n?disalignment # level 1\n?group.dist # level 1\n?point.dist # level 2\n?projections.between # level 2")
 })
 
@@ -350,7 +350,7 @@ test_that("ancestral.dist", {
     test <- dispRity(matrix, metric = ancestral.dist, tree = tree)
     expect_equal(c(test$disparity[[1]][[1]]), unname(ancestral.dist(matrix, tree)))
 
-    ## Works with time slices!
+    ## Works with time slices!
     data(BeckLee_mat99)
     data(BeckLee_tree)
     data <- chrono.subsets(BeckLee_mat99, BeckLee_tree, method = "continuous", model = "acctran", time = 5)
@@ -951,4 +951,13 @@ if(!nocov) {
     #expect_equal_round(unname(unlist(disparity)), c(2.8460391, 1.5703472, 1.2262642, 0.3840770, 0.2397510, 0.7011024), 2)
     expect_equal_round(unname(unlist(lapply(disparity, median))), c(0.06060223, 0.02611046, 0.06848407), 5)
 }
-})
+})
+
+test_that("roudness works", {
+    set.seed(1)
+    dummy_matrix <- matrix(rnorm(50), 5, 10)
+    test <- roundness(dummy_matrix, vcv = TRUE)
+    expect_equal_round(test, 0.1776007)
+    test <- roundness(var(dummy_matrix), vcv = FALSE)
+    expect_equal_round(test, 0.1776007)
+})