Fix first testing issues

DESCRIPTION

@@ -44,7 +44,7 @@ Collate:
     'TrainMetaLayer.R'
     'Training.R'
     'VarSel.R'
-    'entities.R'
+    'multi_omics.R'
     'weightedMeanLearner.R'
     'predict.bestSpecificLearner.R'
     'predict.weightedMeanLearner.R'

NAMESPACE

@@ -32,7 +32,6 @@ export(createTraining)
 export(extractData)
 export(extractModel)
 export(fusemlr)
-export(removeLayer)
 export(upsetplot)
 export(varSelection)
 export(weightedMeanLearner)

R/BestSpecificLearner.R

@@ -23,27 +23,31 @@
 #' my_best_model = bestSpecificLearner(x = x, y = y)
 #'
 bestSpecificLearner = function (x, y, perf = NULL) {
+  if (!is.data.frame(x)) {
+    stop("x must be a data.frame.")
+  }
   if (is.null(perf)) {
-    # y must be binomial for Brier Score estimation.
-    # If dichotomy, first category (case) = 1 and
-    # second (control) = 0
-    if ((length(unique(y)) > 2) | is.character(y)) {
-      stop("y must be either binary or two level factor variable.")
+    if (is.numeric(y) & (length(unique(y)) > 2)) {
+      perf_values = lapply(X = x, FUN = function (predicted) {
+        mean(x = (predicted - y)^2, na.rm = TRUE)
+      })
     } else {
-      if (!all(y %in% 0:1)) {
-        y = 1 - as.integer(y)
+      if ((length(unique(y)) > 2) | is.character(y)) {
+        stop("y must be either binary or two level factor variable.\n")
       } else {
         if (is.factor(y)) {
           y = as.integer(y) - 1
         } else {
-          y = y
+          if (!all(y %in% 0:1)) {
+            stop("y must take its values between 0 and 1.\n")
+          }
         }
+        perf_values = lapply(X = x, FUN = function (predicted) {
+          mean(x = (predicted - y)^2, na.rm = TRUE)
+        })
       }
-      perf_values = lapply(X = x, FUN = function (predicted) {
-        mean(x = (predicted - y)^2L, na.rm = TRUE)
-      })
-      perf_values = unlist(perf_values)
     }
+    perf_values = unlist(perf_values)
   } else {
     # nocov start
     if (is.function(perf)) {

R/HashTable.R

@@ -1,5 +1,5 @@
 #' @title Class HashTable
-#' @description Hashtable to contain object entities. Storage objects like [Training] and [TrainLayer] are extensions of this class.
+#' @description Hashtable to contain object modalities. Storage objects like [Training] and [TrainLayer] are extensions of this class.
 #'
 #' @export
 #' @importFrom R6 R6Class

R/Lrner.R

@@ -42,6 +42,11 @@ Lrner <- R6Class("Lrner",
                      private$lrn_fct = lrn_fct
                      private$param_train = param_train_list
                      private$param_pred = param_pred_list
+                     if (is.null(package)) {
+                       if (!(exists(lrn_fct, envir = .GlobalEnv, inherits = TRUE) | is.function(get(lrn_fct, envir = .GlobalEnv)))) {
+                         stop(sprintf("Function %s does not exists.\n Maybe you forget to specify its package?", lrn_fct))
+                       }
+                     }
                      if (!any(c("TrainLayer", "TrainMetaLayer") %in% class(train_layer))) {
                        stop("A Lrner can only belong to a TrainLayer or a TrainMetaLayer object.")
                      }

R/Testing.R

@@ -23,9 +23,25 @@ Testing <- R6Class("Testing",
                    #' Testing id.
                    #' @param ind_col (`character(1)`)
                    #' Name of column of individuals IDS in testing data.frame.
-                   initialize = function (id, ind_col) {
+                   #' @param verbose (`boolean`) \cr
+                   #' Warning messages will be displayed if set to TRUE.
+                   initialize = function (id, ind_col, verbose = TRUE) {
                      super$initialize(id = id)
                      private$ind_col = ind_col
+                     layers = self$getKeyClass()
+                     layers = layers[layers$class %in% "TestLayer", ]
+                     nb_layers = nrow(layers)
+                     if (nb_layers) {
+                       layer_dims = NULL
+                       for (k in layers$key) {
+                         layer = self$getFromHashTable(key = k)
+                         test_data = layer$getTestData()
+                         layer_dim = ncol(test_data$getData())
+                         layer_dims = c(layer_dims, layer_dim)
+                       }
+                       layer_dims = paste0(layer_dims, collapse = " | ")
+                       cat(sprintf("p               : %s\n", layer_dims))
+                     }
                    },
                    #' @description
                    #' Printer
@@ -36,6 +52,26 @@ Testing <- R6Class("Testing",
                      nb_layers = length(private$hash_table)
                      cat(sprintf("Testing         : %s\n", private$id))
                      cat(sprintf("Number of layers: %s\n", nb_layers))
+                     layers = self$getKeyClass()
+                     layers = layers[layers$class %in% "TestLayer", ]
+                     nb_layers = nrow(layers)
+                     if (nb_layers) {
+                       layer_ps = NULL
+                       layer_ns = NULL
+                       for (k in layers$key) {
+                         layer = self$getFromHashTable(key = k)
+                         test_data = layer$getTestData()
+                         layer_p = ncol(test_data$getData())
+                         layer_n = nrow(test_data$getData())
+                         max_width <- max(nchar(layer_p), nchar(layer_n))
+                         layer_ps = c(layer_ps, format(layer_p, width = max_width, justify = "left"))
+                         layer_ns = c(layer_ns, format(layer_n, width = max_width, justify = "left"))
+                       }
+                       layer_ps = paste0(layer_ps, collapse = " | ")
+                       layer_ns = paste0(layer_ns, collapse = " | ")
+                       cat(sprintf("p               : %s\n", layer_ps))
+                       cat(sprintf("n               : %s\n", layer_ns))
+                     }
                    },
                    #' @description
                    #' Gather individual IDs from all layer.
@@ -81,6 +117,12 @@ Testing <- R6Class("Testing",
                      return(private$ind_col)
                    },
                    #' @description
+                   #' Getter of the verbose setting.
+                   #' @export
+                   getVerbose = function () {
+                     return(private$verbose)
+                   },
+                   #' @description
                    #' UpSet plot to show an overview of the overlap of individuals across various layers.
                    #'
                    #' @param ... \cr
@@ -93,8 +135,8 @@ Testing <- R6Class("Testing",
                      # This code accesses each layer (except TrainMetaLayer) level
                      # and get the individual IDs.
                      layers = layers[layers$class %in% "TestLayer", ]
-                     if (!nrow(layers)) {
-                       stop("No available layer in this testing object.")
+                     if (!nrow(layers) | (nrow(layers) == 1L)) {
+                       stop("No or only one available layer in this training object.")
                      }
                      ids_list = lapply(layers$key, function (k) {
                        layer = self$getFromHashTable(key = k)
@@ -129,7 +171,8 @@ Testing <- R6Class("Testing",
                    }
                  ),
                  private = list(
-                   ind_col = character(0L)
+                   ind_col = character(0L),
+                   verbose = TRUE
                  ),
                  cloneable = FALSE
 )

R/TrainData.R

@@ -26,6 +26,9 @@ TrainData <- R6Class("TrainData",
                          if (!any(c("TrainLayer", "TrainMetaLayer") %in% class(train_layer))) {
                            stop("A Traindata can only belong a TrainLayer or a TrainMetaLayer object.\n")
                          }
+                         if (!is.data.frame(data_frame)) {
+                           stop("data_frame must be a data.frame.\n")
+                         }
                          target_obj = train_layer$getTargetObj()
                          target_df = target_obj$getData()
                          ind_col = train_layer$getTraining()$getIndCol()
@@ -39,6 +42,19 @@ TrainData <- R6Class("TrainData",
                            }
                            data_frame[ , target] = NULL
                          }
+                         if (!all(data_frame[ , ind_col] %in% target_df[ , ind_col])) {
+                           cat("The following IDs do not exist in target:\n")
+                           id_not_in = !(data_frame[ , ind_col] %in% target_df[ , ind_col])
+                           cat(data_frame[id_not_in , ind_col], "\n")
+                           if (length(id_not_in) == nrow(data_frame)) {
+                             stop("None of the provided IDs have a match in the target.\n")
+                           } else {
+                             if (length(id_not_in) <= nrow(data_frame)) {
+                               data_frame = data_frame[!(data_frame[ , ind_col] %in% id_not_in), ]
+                               warning("Not matching ID(s) removed:\n")
+                             }
+                           }
+                         }
                          if (train_layer$checkTrainDataExist()) {
                            # Remove TrainData if already existing
                            key_class = train_layer$getKeyClass()
@@ -77,7 +93,7 @@ TrainData <- R6Class("TrainData",
                                                      .class = "TrainData")
                          }
                          if (any(missing_target)) {
-                           warning(sprintf("%s individual(s) with missing target value(s) recognized and removed\n",
+                           warning(sprintf("%s individual(s) with missing target value(s) recognized and removed.\n",
                                            sum(missing_target)))
                          }
                          if (any(missing_id)) {