Ipad 512

R/plots.R

@@ -246,13 +246,22 @@ getMappingPlottingData <- function(study = study, modelID = modelID, featureID =
     )
   }
   if (!all(featureID %in% model_features)) {
-    message(
+    stop(
       sprintf(
-        "The provided features list contains at least one feature not present in model '%s' from mapping object.",
+        "At least one feature is not present in the first model passed, '%s'.",
         modelID[1]
-      ),
+      )
+    )
+  }
+
+  secondary_mapping  <- mapping[which(mapping[, modelID[1]] %in% featureID), ]
+  secondary_mapping[, modelID[1]]  <- NULL
+  secondary_features <- data.frame(secondary_mapping[rowSums(is.na(secondary_mapping)) != ncol(secondary_mapping),])
+  if (nrow(secondary_features) == 0) {
+    stop(
       sprintf(
-        "\nOnly features available in the mapping object will be shown."
+        "The features are only present in the first model passed, '%s'.",
+        modelID[1]
       )
     )
   }
@@ -265,6 +274,22 @@ getMappingPlottingData <- function(study = study, modelID = modelID, featureID =
       sprintf("testID: %s", paste(testID, collapse = ", "))
     )
   }
+  # Inform user if at least one feature from modelID is not present in secondary models
+  incomplete_matches_sec_models = NULL
+  for (ii in colnames(mapping)) {
+    if (ii == modelID[1]) next
+    if (any(is.na(mapping[ii]))) {
+      incomplete_matches_sec_models <- trimws(paste(incomplete_matches_sec_models, ii, collapse=' '))
+    }
+  }
+  if (!is.null(incomplete_matches_sec_models)) {
+    warning(
+      sprintf("At least one feature from model '%s' is not mapped in other model(s). Model(s) impacted: %s",
+              modelID[1],
+              incomplete_matches_sec_models
+              )
+    )
+  }
 
   # Structuring data for mapping
   mappingdf <- as.data.frame(mapping, stringsAsFactors = FALSE)
@@ -362,6 +387,53 @@ getPlottingData <- function(study, modelID, featureID, testID = NULL, libraries
     mapping_features <- mappingPlottingData$mapping_features
     testID_all <- mappingPlottingData$testID_all
     modelID <- mappingPlottingData$modelID
+
+    # Error if test passed to testID associated with modelID[1] is not available in study object
+    incomplete_test_matches_sec_models = NULL
+    incomplete_test_matches = list()
+    current_model_tests <- testID[modelID %in% modelID[1]]
+    for (i_current_model_tests in current_model_tests) {
+      tmp <- getResults(study, modelID = modelID[1], testID = i_current_model_tests)
+      if (isEmpty(tmp)) {
+        stop(
+          sprintf("Test '%s' from testID is not available in selected model '%s'.",
+                  i_current_model_tests,
+                  modelID[1])
+        )
+      } else { rm(tmp) }
+    }
+
+    # Warning if at least one test from modelID[1] is not available in secondary models
+    for (ii in unique(modelID)) {
+      if (ii == modelID[1]) next
+      secondary_model_tests = testID[modelID %in% ii]
+      for (i_secondary_model_tests in secondary_model_tests) {
+        tmp <- suppressMessages(getResults(study, modelID = ii, testID = i_secondary_model_tests))
+        if (isEmpty(tmp)) {
+          secondary_model_tests <- secondary_model_tests[!secondary_model_tests %in% i_secondary_model_tests]
+        } else { rm(tmp) }
+      }
+      if (isEmpty(secondary_model_tests)) secondary_model_tests <- NULL
+      incomplete_test_matches_sec_models = !current_model_tests %in% secondary_model_tests
+
+      if (any(incomplete_test_matches_sec_models)) {
+        incomplete_test_matches[[ii]] = current_model_tests[incomplete_test_matches_sec_models]
+      }
+    }
+
+
+    if (!isEmpty(incomplete_test_matches)) {
+      unmatched_tests <- NULL
+      for (inames in names(incomplete_test_matches)) {
+        unmatched_tests <- c(unmatched_tests, incomplete_test_matches[[inames]])
+      }
+      unmatched_tests <- paste0(unique(unmatched_tests), collapse=", ")
+      warning(
+        sprintf("At least one test from model '%s' is not available in other model(s). Test(s) impacted: %s",
+                modelID[1],
+                unmatched_tests)
+      )
+    }
   }
 
   for (ii in 1:length(modelID)) {
@@ -385,10 +457,30 @@ getPlottingData <- function(study, modelID, featureID, testID = NULL, libraries
       stop(sprintf("No assays available for modelID \"%s\"\n", model_i),
            "Add assays data with addAssays()")
     } else {
-      featureIDAvailable <- featureID %in% rownames(assays)
-      if (any(!featureIDAvailable)) {
-        stop(sprintf("The feature \"%s\" is not available for modelID \"%s\"",
-                     featureID[!featureIDAvailable][1], model_i))
+      # only necessary for singleModel plots - for multiModel the check is done at getMappingPlottingData
+      if (length(modelID) == 1) {
+        if (!is.null(testID)) {
+          featID_tmp <- NULL
+          for (i_testID in testID) {
+            tmp <- getResults(study, modelID = model_i, testID = i_testID, quiet = TRUE,
+                              libraries = libraries)
+            if (is.data.frame(tmp)) {
+              featID_tmp <- unique(c(featID_tmp, tmp[[1]]))
+            }
+          }
+          featureIDAvailable <- featureID %in% featID_tmp
+          if (any(!featureIDAvailable)) {
+            stop(sprintf("At least one feature is not available in the results object for modelID \"%s\": \"%s\"",
+                         model_i, featureID[!featureIDAvailable][1]))
+          }
+        }
+        if (is.null(testID) || (!is.null(testID) && !is.data.frame(tmp))) {
+          featureIDAvailable <- featureID %in% rownames(assays)
+          if (any(!featureIDAvailable)) {
+            stop(sprintf("At least one feature is not available in the assay object for modelID \"%s\": \"%s\"",
+                         model_i, featureID[!featureIDAvailable][1]))
+          }
+        }
       }
       assaysPlotting <- assays[featureID, , drop = FALSE]
     }
@@ -423,6 +515,16 @@ getPlottingData <- function(study, modelID, featureID, testID = NULL, libraries
       for (i in seq_along(testID)) {
         results <- getResults(study, modelID = model_i, testID = testID[i], quiet = TRUE,
                               libraries = libraries)
+
+        if (length(modelID) > 1) {
+          if (model_i %in% names(incomplete_test_matches)) {
+            if (testID %in% incomplete_test_matches[[model_i]]) {
+              resultsPlotting[[i]] <- NULL
+              next
+            }
+          }
+        }
+
         if (isEmpty(results)) {
           stop(sprintf("The test result (testID) \"%s\" is not available for modelID \"%s\" ", testID[i], model_i))
         }
@@ -446,13 +548,15 @@ getPlottingData <- function(study, modelID, featureID, testID = NULL, libraries
           samples = samplesPlotting,
           features = featuresPlotting
         )
-        if (!isEmpty(testID)) temp_model <- c(temp_model, list(results = stats::setNames(list(resultsPlotting), testID)))
+        if (!isEmpty(testID) && (!isEmpty(resultsPlotting))) temp_model <- c(temp_model, list(results = stats::setNames(list(resultsPlotting), testID)))
         plottingData <- c(plottingData, stats::setNames(list(temp_model), model_i))
 
       } else if (sum(modelID %in% model_i) > 1 & exists("resultsPlotting")) {
-        resultsPlotting <- list(resultsPlotting)
-        names(resultsPlotting) <- testID
-        plottingData[[model_i]]$results <- c(plottingData[[model_i]]$results, resultsPlotting)
+        if (!isEmpty(resultsPlotting)) {
+          resultsPlotting <- list(resultsPlotting)
+          names(resultsPlotting) <- testID
+          plottingData[[model_i]]$results <- c(plottingData[[model_i]]$results, resultsPlotting)
+        }
       }
 
       if (ii == length(modelID)) {

R/validate.R

@@ -333,7 +333,7 @@ validateMapping <- function(study) {
       }
       # Check whether mapping features match results features
       mappingFeatures <- mapping[[i]][!is.na(mapping[[i]][,ii]),ii]
-      modelFeatures   <- results[[grep(mappingID, models)]][1][[1]][,1]
+      modelFeatures   <- results[[grep(paste0("^",mappingID,"$"), models)]][1][[1]][,1]
       if (!length(intersect(mappingFeatures, modelFeatures)) > 0) {
         stop("Mapping features for modelID do not match features from modelID results table\n",
              sprintf("modelID: %s", mappingID))

inst/tinytest/testPlot.R

@@ -212,7 +212,7 @@ expect_error_xl(
 mmodel <- names(testStudyObj[["models"]])[1:2]
 mmtestID <- c("test_01", "test_02")
 
-expect_silent_xl(
+expect_warning_xl(
   plotStudy(
     testStudyName,
     modelID = mmodel,
@@ -233,15 +233,15 @@ expect_error_xl(
   "Plot type \"multiModel\" requires testID to be either NULL \\(default\\) or a vector containing at least 2 testIDs"
 )
 
-expect_message_xl(
+expect_error_xl(
   plotStudy(
     testStudyName,
     modelID = mmodel,
     featureID = c("feature_0026", "feature_0001", "feature_0002", "feature_0010"),
     plotID = "multiModel_scatterplot",
     testID = c("test_01", "test_02")
   ),
-  "The provided features list contains at least one feature not present in model"
+  "At least one feature is not present in the first model passed"
 )
 
 expect_error_xl(
@@ -287,7 +287,7 @@ expect_silent_xl(
 expect_error_xl(
   plotStudy(testStudyName, modelID = "model_01", featureID = "feature_0001",
             plotID = "plotBase", testID = "non-existent"),
-  "non-existent"
+  "one feature is not available in the results object for model"
 )
 
 expect_error_xl(
@@ -505,12 +505,12 @@ rm(plottingData)
 mmodel <- names(testStudyObj[["models"]])[1:2]
 mmtestID <- c("test_01", "test_02")
 
-plottingData <- getPlottingData(
+suppressWarnings(plottingData <- getPlottingData(
   testStudyObj,
   modelID = mmodel,
   featureID = c("feature_0010", "feature_0020"),
   testID = mmtestID
-)
+))
 
 expect_true_xl(
   inherits(plottingData, "list")
@@ -569,18 +569,18 @@ expect_true_xl(
 
 rm(plottingData)
 
-# getPlottingData (package, multiModel) -----------------------------------------
+# getPlottingData (package, multiModel) ----------------------------------------
 
 mmodel <- names(testStudyObj[["models"]])[1:2]
 mmtestID <- c("test_01", "test_02")
 names(mmtestID) <- mmodel
 
-plottingData <- getPlottingData(
+suppressWarnings(plottingData <- getPlottingData(
   testStudyName,
   modelID = mmodel,
   featureID = c("feature_0010", "feature_0020"),
   testID = mmtestID
-)
+))
 
 expect_true_xl(
   inherits(plottingData, "list")