From a9ade606746de5dc4d58e6dac1e0c4821d365e0f Mon Sep 17 00:00:00 2001 From: GFabien Date: Fri, 2 Feb 2024 10:39:16 +0100 Subject: [PATCH] Fix plots for TGCCA --- NAMESPACE | 2 +- R/plot.rgcca.R | 23 ++++++++++++++---- R/rgcca_predict.R | 2 +- R/subset_block_rows.R | 2 +- R/subset_rows.R | 20 ---------------- tests/testthat/test_handle_NA.r | 2 +- tests/testthat/test_intersection_list.r | 4 ++-- tests/testthat/test_subset_block_rows.R | 32 +++++++++++++++++++++++++ tests/testthat/test_subset_rows.r | 32 ------------------------- 9 files changed, 56 insertions(+), 63 deletions(-) delete mode 100644 R/subset_rows.R create mode 100644 tests/testthat/test_subset_block_rows.R delete mode 100644 tests/testthat/test_subset_rows.r diff --git a/NAMESPACE b/NAMESPACE index e3ec6ad1..18119324 100644 --- a/NAMESPACE +++ b/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) diff --git a/R/plot.rgcca.R b/R/plot.rgcca.R index 7f5ecec6..72f26d32 100644 --- a/R/plot.rgcca.R +++ b/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] )) diff --git a/R/rgcca_predict.R b/R/rgcca_predict.R index 91eb2063..e2cef6f0 100644 --- a/R/rgcca_predict.R +++ b/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) { diff --git a/R/subset_block_rows.R b/R/subset_block_rows.R index 175b74aa..8d36b6cc 100644 --- a/R/subset_block_rows.R +++ b/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]) } diff --git a/R/subset_rows.R b/R/subset_rows.R deleted file mode 100644 index 1e17ee9c..00000000 --- a/R/subset_rows.R +++ /dev/null @@ -1,20 +0,0 @@ -#' The function subset_rows extracts rows from an object (vector, matrix, array, -#' data.frame). -#' @param x An object from which we want to extract rows -#' @param rows A set of rows -#' @noRd -subset_rows <- function(x, rows) { - is.x.data.frame <- is.data.frame(x) - if (is.x.data.frame) { - row.names <- attr(x, "row.names")[rows] - } - if (is.vector(x)) { - x <- x[rows] - } else { - x <- apply(x, -1, "[", rows) - } - if (is.x.data.frame) { - x <- data.frame(x, row.names = row.names) - } - return(x) -} diff --git a/tests/testthat/test_handle_NA.r b/tests/testthat/test_handle_NA.r index ebe84763..cbd126ca 100644 --- a/tests/testthat/test_handle_NA.r +++ b/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) } }) diff --git a/tests/testthat/test_intersection_list.r b/tests/testthat/test_intersection_list.r index f4259ae4..d6a1bd67 100644 --- a/tests/testthat/test_intersection_list.r +++ b/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)) } }) diff --git a/tests/testthat/test_subset_block_rows.R b/tests/testthat/test_subset_block_rows.R new file mode 100644 index 00000000..bf668d2e --- /dev/null +++ b/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), ]) +}) diff --git a/tests/testthat/test_subset_rows.r b/tests/testthat/test_subset_rows.r deleted file mode 100644 index ebdbcfa0..00000000 --- a/tests/testthat/test_subset_rows.r +++ /dev/null @@ -1,32 +0,0 @@ -# '# Test subset_rows -# -# ''' -test_that("subset_rows successfully extract rows of vectors", { - x <- 1:10 - expect_equal(subset_rows(x, c(3, 5, 6)), x[c(3, 5, 6)]) - names(x) <- paste0("V", 1:10) - expect_equal(subset_rows(x, c(3, 5, 6)), x[c(3, 5, 6)]) -}) - -test_that("subset_rows successfully extract rows of matrices", { - x <- matrix(1:21, 7, 3) - expect_equal(subset_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_rows(x, c(3, 5, 6)), x[c(3, 5, 6), ]) -}) - -test_that("subset_rows successfully extract rows of arrays", { - x <- array(1:72, dim = c(6, 3, 2, 2)) - expect_equal(subset_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_rows(x, c(3, 5, 6)), x[c(3, 5, 6), , , ]) -}) - -test_that("subset_rows successfully extract rows of data.frames", { - x <- as.data.frame(matrix(1:21, 7, 3)) - expect_equal(subset_rows(x, c(3, 5, 6)), x[c(3, 5, 6), ]) -})