Add probs as output of rgcca_predict

R/rgcca_predict.R

@@ -24,6 +24,10 @@
 #' block is missing.}
 #' @return \item{model}{A list of the models trained using caret to make the
 #' predictions and compute the scores.}
+#' @return \item{probs}{A list of data.frames with the class probabilities
+#' of the test and train response blocks predicted by the prediction
+#' model. If the prediction model does not compute class probabilities, the
+#' data.frames are empty.}
 #' @return \item{metric}{A list of data.frames containing the scores obtained
 #' on the training and testing sets.}
 #' @return \item{confusion}{A list containing NA for regression tasks.
@@ -156,9 +160,15 @@ rgcca_predict <- function(rgcca_res,
     }))
   })
 
+  probs <- lapply(c("train", "test"), function(mode) {
+    as.data.frame(lapply(results, function(res) {
+      res[["probs"]][[mode]]
+    }))
+  })
+
   confusion <- results[[1]]$confusion
 
-  names(prediction) <- names(metric) <- c("train", "test")
+  names(prediction) <- names(metric) <- names(probs) <- c("train", "test")
 
   model <- lapply(results, "[[", "model")
   score <- mean(unlist(lapply(results, "[[", "score")), na.rm = TRUE)
@@ -169,6 +179,7 @@ rgcca_predict <- function(rgcca_res,
     prediction = prediction,
     confusion = confusion,
     metric = metric,
+    probs = probs,
     model = model,
     score = score
   )
@@ -221,22 +232,18 @@ core_prediction <- function(prediction_model, X_train, X_test,
   idx_train <- !(is.na(prediction_train$obs) | is.na(prediction_train$pred))
   idx_test <- !(is.na(prediction_test$obs) | is.na(prediction_test$pred))
 
+  probs_train <- probs_test <- NULL
+
   if (classification) {
     confusion_train <- confusionMatrix(prediction_train$pred,
       reference = prediction_train$obs
     )
     confusion_test <- confusionMatrix(prediction_test$pred,
       reference = prediction_test$obs
     )
-    if (is.null(prediction_model$prob)) {
-      prediction_train <- data.frame(cbind(
-        prediction_train,
-        predict(model, X_train, type = "prob")
-      ))
-      prediction_test <- data.frame(cbind(
-        prediction_test,
-        predict(model, X_test, type = "prob")
-      ))
+    if (is.function(prediction_model$prob)) {
+      probs_train <- data.frame(predict(model, X_train, type = "prob"))
+      probs_test <- data.frame(predict(model, X_test, type = "prob"))
     }
     metric_train <- multiClassSummary(
       data = prediction_train[idx_train, ],
@@ -268,6 +275,7 @@ core_prediction <- function(prediction_model, X_train, X_test,
   return(list(
     score = score,
     model = model,
+    probs = list(train = probs_train, test = probs_test),
     metric = list(train = metric_train, test = metric_test),
     confusion = list(train = confusion_train, test = confusion_test),
     prediction = list(train = prediction_train, test = prediction_test)

tests/testthat/test_rgcca_predict.r

@@ -90,6 +90,12 @@ test_that("rgcca_predict with lm predictor gives the same prediction as
   expect_equal(as.matrix(A[[response]] - res_predict$prediction$test), res_lm)
 })
 
+test_that("rgcca_predict returns an empty probs in regression", {
+  res_predict <- rgcca_predict(rgcca_res = fit_rgcca)
+  expect_equal(nrow(res_predict$probs$train), 0)
+  expect_equal(nrow(res_predict$probs$test), 0)
+})
+
 # Classification
 #---------------
 test_that("rgcca_predict with lda predictor gives the same prediction as
@@ -109,3 +115,16 @@ test_that("rgcca_predict with lda predictor gives the same prediction as
     data.frame(politic = prediction_lda)
   )
 })
+
+test_that("rgcca_predict returns probs in classification with adequate model", {
+  A <- lapply(blocks_classif, function(x) x[1:32, ])
+  B <- lapply(blocks_classif, function(x) x[33:47, ])
+  response <- 3
+  fit_rgcca <- rgcca(A, tau = 1, ncomp = c(3, 2, 1), response = response)
+  res_predict <- rgcca_predict(fit_rgcca,
+                               blocks_test = B[-3],
+                               prediction_model = "lda"
+  )
+  expect_equal(nrow(res_predict$probs$train), 32)
+  expect_equal(nrow(res_predict$probs$test), 15)
+})