Fix plots for TGCCA

NAMESPACE

@@ -36,7 +36,7 @@ S3method(shaving,double)
 S3method(shaving,matrix)
 S3method(subset_block_rows,array)
 S3method(subset_block_rows,data.frame)
-S3method(subset_block_rows,vector)
+S3method(subset_block_rows,numeric)
 S3method(summary,rgcca)
 S3method(summary,rgcca_bootstrap)
 S3method(summary,rgcca_cv)

R/plot.rgcca.R

@@ -209,6 +209,17 @@ plot.rgcca <- function(x, type = "weights",
                        show_var_names = TRUE, repel = FALSE,
                        display_blocks = seq_along(x$call$blocks),
                        expand = 1, show_arrows = TRUE, ...) {
+  ### Define utility function to get named matrix out of array block
+  to_mat <- function(x, block) {
+    if (is.matrix(x$blocks[[block]])) {
+      return(x$blocks[[block]])
+    }
+    z <- matrix(x$blocks[[block]], nrow = nrow(x$blocks[[block]]))
+    rownames(z) <- rownames(x$blocks[[block]])
+    colnames(z) <- rownames(x$a[[block]])
+    return(z)
+  }
+
   ### Define data.frame generating functions
   df_sample <- function(x, block, comp, response, obj = "Y") {
     data.frame(
@@ -222,12 +233,14 @@ plot.rgcca <- function(x, type = "weights",
     df <- data.frame(
       x = do.call(rbind, Map(function(i, j) {
         cor2(
-          x$blocks[[i]][rownames(x$Y[[j]]), ],
+          subset_block_rows(to_mat(x, i), rownames(x$Y[[j]])),
           x$Y[[j]][, comp]
         )
       }, display_blocks, block)),
       response = num_block,
-      y = do.call(c, lapply(x$blocks[display_blocks], colnames))
+      y = do.call(
+        c, lapply(display_blocks, function(j) colnames(to_mat(x, j)))
+      )
     )
 
     idx <- unlist(
@@ -239,7 +252,7 @@ plot.rgcca <- function(x, type = "weights",
   df_weight <- function(x, block, comp, num_block, display_order) {
     df <- data.frame(
       x = unlist(lapply(x$a[block], function(z) z[, comp[1]])),
-      y = do.call(c, lapply(x$blocks[block], colnames)),
+      y = do.call(c, lapply(block, function(j) colnames(to_mat(x, j)))),
       response = num_block
     )
     df <- df[df$x != 0, ]
@@ -397,7 +410,7 @@ plot.rgcca <- function(x, type = "weights",
   # Construct response vector for correlation circle, weights and loadings
   num_block <- as.factor(unlist(lapply(
     display_blocks,
-    function(j) rep(names(x$blocks)[j], NCOL(x$blocks[[j]]))
+    function(j) rep(names(x$blocks)[j], prod(dim(x$blocks[[j]])[-1]))
   )))
 
   switch(type,
@@ -481,7 +494,7 @@ plot.rgcca <- function(x, type = "weights",
       )
 
       # Rescale weigths
-      var_tot <- sum(diag(var(x$blocks[[block[1]]], na.rm = TRUE)))
+      var_tot <- sum(diag(var(to_mat(x, block[1]), na.rm = TRUE)))
       a <- data.matrix(df$a[, c(1, 2)]) %*% diag(sqrt(
         var_tot * x$AVE$AVE_X[[block[1]]][comp]
       ))

R/rgcca_predict.R

@@ -110,7 +110,7 @@ rgcca_predict <- function(rgcca_res,
   X_test <- reformat_projection(projection)
 
   # Keep same lines in X_train and y_train
-  y_train <- as.data.frame(subset_rows(y_train, rownames(X_train)))
+  y_train <- as.data.frame(subset_block_rows(y_train, rownames(X_train)))
 
   # Test that in classification, variables are not constant within groups
   if (classification) {

R/subset_block_rows.R

@@ -3,7 +3,7 @@ subset_block_rows <- function(x, rows, drop = TRUE) {
 }
 
 #' @export
-subset_block_rows.vector <- function(x, rows, drop = TRUE) {
+subset_block_rows.numeric <- function(x, rows, drop = TRUE) {
   return(x[rows])
 }
 

tests/testthat/test_handle_NA.r

@@ -23,7 +23,7 @@ test_that("handle_NA selects the common rows without missing values when
   NA_method is \"na.omit\"", {
   tmp <- handle_NA(blocks, NA_method = "na.omit")
   for (j in seq_along(blocks)) {
-    expect_equal(tmp$blocks[[j]], subset_rows(blocks[[j]], -ind_NA))
+    expect_equal(tmp$blocks[[j]], subset_block_rows(blocks[[j]], -ind_NA))
     expect_false(tmp$na.rm)
   }
 })

tests/testthat/test_intersection_list.r

@@ -22,7 +22,7 @@ ind_NA <- c(2, 4, 8, 12, 17, 23, 30, 32, 40, 42)
 test_that("intersection_list selects the common rows without missing values", {
   blocks_inter <- intersection_list(blocks)
   for (j in seq_along(blocks)) {
-    expect_equal(blocks_inter[[j]], subset_rows(blocks[[j]], -ind_NA))
+    expect_equal(blocks_inter[[j]], subset_block_rows(blocks[[j]], -ind_NA))
   }
 })
 test_that("intersection_list raises an error if there is less than 3 subjects
@@ -51,6 +51,6 @@ test_that("intersection_list selects the common rows without missing
           values with arrays", {
   blocks_inter <- intersection_list(blocks)
   for (j in seq_along(blocks)) {
-    expect_equal(blocks_inter[[j]], subset_rows(blocks[[j]], -ind_NA))
+    expect_equal(blocks_inter[[j]], subset_block_rows(blocks[[j]], -ind_NA))
   }
 })

tests/testthat/test_subset_block_rows.R

@@ -0,0 +1,32 @@
+# '# Test subset_block_rows
+#
+# '''
+test_that("subset_block_rows successfully extract rows of vectors", {
+  x <- 1:10
+  expect_equal(subset_block_rows(x, c(3, 5, 6)), x[c(3, 5, 6)])
+  names(x) <- paste0("V", 1:10)
+  expect_equal(subset_block_rows(x, c(3, 5, 6)), x[c(3, 5, 6)])
+})
+
+test_that("subset_block_rows successfully extract rows of matrices", {
+  x <- matrix(1:21, 7, 3)
+  expect_equal(subset_block_rows(x, c(3, 5, 6)), x[c(3, 5, 6), ])
+  rownames(x) <- paste0("R", 1:7)
+  colnames(x) <- paste0("C", 1:3)
+  expect_equal(subset_block_rows(x, c(3, 5, 6)), x[c(3, 5, 6), ])
+})
+
+test_that("subset_block_rows successfully extract rows of arrays", {
+  x <- array(1:72, dim = c(6, 3, 2, 2))
+  expect_equal(subset_block_rows(x, c(3, 5, 6)), x[c(3, 5, 6), , , ])
+  dimnames(x)[[1]] <- paste0("A", 1:6)
+  dimnames(x)[[2]] <- paste0("B", 1:3)
+  dimnames(x)[[3]] <- paste0("C", 1:2)
+  dimnames(x)[[4]] <- paste0("D", 1:2)
+  expect_equal(subset_block_rows(x, c(3, 5, 6)), x[c(3, 5, 6), , , ])
+})
+
+test_that("subset_block_rows successfully extract rows of data.frames", {
+  x <- as.data.frame(matrix(1:21, 7, 3))
+  expect_equal(subset_block_rows(x, c(3, 5, 6)), x[c(3, 5, 6), ])
+})