modified mpm_elementwise_apply to correct errors and rebuild

NAMESPACE

@@ -44,6 +44,7 @@ export(mat_median)
 export(mat_sd)
 export(mat_to_string)
 export(matrixClass)
+export(mpm_elementwise_apply)
 export(mpm_first_active)
 export(mpm_has_active)
 export(mpm_has_dorm)

R/mpm_elementwise_apply.R

@@ -3,18 +3,19 @@
 #' This function applies a specified function element-wise to the corresponding
 #' elements across a list of matrices.
 #'
-#' @param matrix_list A list of matrices.
+#' @param x A list of matrices.
 #' @param fun The function to apply to the elements.
 #' @param na_handling A character string specifying how to handle NA values.
 #'   Possible values are "stop" (throw an error when NA values are encountered),
 #'   "zero" (convert NA values to 0), and "ignore" (NA values are ignored and
 #'   passed to `fun`). Handling can then be processed appropriately by that
 #'   function (e.g., with `na.rm`).
+#' @param ... Additional arguments passed to `fun`.
 #'
 #' @return A matrix containing the result of applying the function element-wise
 #'   to the corresponding elements across the matrices.
 #'   
-#' @name mat_elementwise_apply
+#' @name mpm_elementwise_apply
 #' @family data management
 #' 
 #' @examples
@@ -23,6 +24,11 @@
 #' #The object mpms is a list, containing compadre objects
 #' class(mpms)
 #' class(mpms[[1]])
+#' 
+#' # Get the mean, max and min for the matrices
+#' mpm_elementwise_apply(mpms, mean)
+#' mpm_elementwise_apply(mpms, max)
+#' mpm_elementwise_apply(mpms, min)
 #'
 #' # extract list of matA and take mean
 #' mats <- matA(mpms)
@@ -57,12 +63,12 @@
 #' mat_elementwise_apply(mats, min, na_handling = "ignore", na.rm = TRUE)
 NULL
 
-#' @rdname mat_elementwise_apply
+#' @rdname mpm_elementwise_apply
 #' @importFrom stats sd
 #' @export
-mat_elementwise_apply <- function(matrix_list, fun, na_handling = "stop", ...) {
+mat_elementwise_apply <- function(x, fun, na_handling = "stop", ...) {
   # Input validation
-  if (!is.list(matrix_list) || any(!sapply(matrix_list, is.matrix))) {
+  if (!is.list(x) || any(!sapply(x, is.matrix))) {
     stop("Input must be a list of matrices.")
   }
 
@@ -76,13 +82,13 @@ mat_elementwise_apply <- function(matrix_list, fun, na_handling = "stop", ...) {
   }
 
   # Get the dimension of the matrices
-  n <- nrow(matrix_list[[1]])
+  n <- nrow(x[[1]])
 
   # Apply the function to each element across matrices
   result <- matrix(0, nrow = n, ncol = n)
   for (i in 1:n) {
     for (j in 1:n) {
-      elements <- sapply(matrix_list, "[", i, j)
+      elements <- sapply(x, "[", i, j)
 
       # Handle NA values based on the specified option
       if (na_handling == "stop" && any(is.na(elements))) {
@@ -98,4 +104,54 @@ mat_elementwise_apply <- function(matrix_list, fun, na_handling = "stop", ...) {
   }
 
   result
+}
+
+#' @rdname mpm_elementwise_apply
+#' @importFrom methods new
+#' @export
+mpm_elementwise_apply <- function(x, fun, na_handling = "stop", ...) {
+  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"
+    )
+  }
+
+  summaryA <- mat_elementwise_apply(matA, fun = fun, na_handling = na_handling, ...)
+  summaryU <- mat_elementwise_apply(matU, fun = fun, na_handling = na_handling, ...)
+  summaryF <- mat_elementwise_apply(matF, fun = fun, na_handling = na_handling, ...)
+  summaryC <- mat_elementwise_apply(matC, fun = fun, na_handling = na_handling, ...)
+
+  new("CompadreMat",
+      matA = summaryA,
+      matU = summaryU,
+      matF = summaryF,
+      matC = summaryC,
+      matrixClass = x[[1]]@matrixClass
+  )
 }