Added mpm_median to accompany mat_median

R/mpm_summaries.R

@@ -1,9 +1,16 @@
-#' Calculate a median over a list of matrices
+#' Calculate a median over a list of matrices or CompadreMat objects
 #'
-#' Calculates an element-wise median over a list of matrices of constant
-#' dimension.
+#' Calculates an element-wise median over a list of matrices or
+#' CompadreMat objects of constant dimension.
+#' 
+#' The difference between function \code{mat_median}) and (\code{mpm_median} is that
+#' \code{mat_median} takes input as a list of matrices (e.g., a list of **A**
+#' matrices) while \code{mat_median} takes input as a list of `CompadreMat` objects and
+#' thus calculates the mean matrices for both the **A** matrix and its
+#' submatrices (**U**, **F**, **C**).
 #'
-#' @param x List of matrices all of same dimension
+#' @param x A list of matrices or, for \code{mpm_sd} a list of `CompadreMat` objects,
+#'   all of the same dimension
 #' @param na.rm Logical indicating whether missing values should be excluded
 #'   (see \emph{Details}). Defaults to \code{FALSE}.
 #'
@@ -37,6 +44,7 @@
 #' mat_median(matA(my_compadre))
 #'
 #' @author Darren Norris
+#' @author Owen R. Jones <jones@@biology.sdu.dk>
 #'
 #' @family data management
 #' @importFrom stats median
@@ -64,6 +72,57 @@ mat_median <- function(x, na.rm = FALSE) {
 }
 
 
+#' @rdname mpm_median
+#' @importFrom methods new
+#' @export
+mpm_median <- function(x, na.rm = FALSE) {
+  if(!inherits(x, "list")){
+    stop("x must be a list of CompadreMat objects")
+  }
+  if(!inherits(x[[1]], "CompadreMat")){
+    stop("x must be a list of CompadreMat objects")
+  }
+
+  #Use lapply to get matrices, stages when x is a list of compadre objects
+  matA <- lapply(x, function(m) m@matA)
+  matU <- lapply(x, function(m) m@matU)
+  matF <- lapply(x, function(m) m@matF)
+  matC <- lapply(x, function(m) m@matC)
+  stage_org <- lapply(x, function(m) m@matrixClass$MatrixClassOrganized)
+  stage_aut <- lapply(x, function(m) m@matrixClass$MatrixClassAuthor)
+
+  stage_org_col <- vapply(stage_org, paste, collapse = " ", "")
+  stage_aut_col <- vapply(stage_aut, paste, collapse = " ", "")
+  if (length(unique(stage_org_col)) != 1L) {
+    warning(
+      "CompadreMat objects in given list do not all have the same ",
+      "MatrixClassOrganized. Returning MatrixClassOrganized from ",
+      "first list element"
+    )
+  }
+  if (length(unique(stage_aut_col)) != 1L) {
+    warning(
+      "CompadreMat objects in given list do not all have the same ",
+      "MatrixClassAuthor. Returning MatrixClassAuthor from first ",
+      "list element"
+    )
+  }
+
+  medianA <- mat_median(matA, na.rm = na.rm)
+  medianU <- mat_median(matU, na.rm = na.rm)
+  medianF <- mat_median(matF, na.rm = na.rm)
+  medianC <- mat_median(matC, na.rm = na.rm)
+
+  new("CompadreMat",
+      matA = medianA,
+      matU = medianU,
+      matF = medianF,
+      matC = medianC,
+      matrixClass = x[[1]]@matrixClass
+  )
+}
+
+
 #' Calculate a standard deviation over a list of matrices or CompadreMat objects
 #'
 #' Calculates an element-wise standard deviation over a list of matrices or
@@ -110,7 +169,8 @@ mat_median <- function(x, na.rm = FALSE) {
 #' mat_sd(matA(my_compadre))
 #'
 #' @author Darren Norris
-#'
+#' @author Owen R. Jones <jones@@biology.sdu.dk>
+#' 
 #' @family data management
 #'
 #' @importFrom stats sd