From ccac7db476e2cde6ffb613cc52dbe499111ffd21 Mon Sep 17 00:00:00 2001 From: Rocha Curado Date: Tue, 25 Jun 2024 15:26:14 +0200 Subject: [PATCH 1/6] implementing changes in feature handling as described in IPAD-512; (1) for multimodel, trigger message if at least one feature is available only in selected model, (2) error message if at least one feature is not found in results obj for single model plots --- R/plots.R | 40 ++++++++++++++++++++++++++++++++++++---- inst/tinytest/testPlot.R | 2 +- 2 files changed, 37 insertions(+), 5 deletions(-) diff --git a/R/plots.R b/R/plots.R index ceced22..20fc6ed 100644 --- a/R/plots.R +++ b/R/plots.R @@ -265,6 +265,17 @@ 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 + for (ii in colnames(mapping)) { + if (ii == modelID[1]) next + if (any(is.na(mapping[ii]))) { + message( + sprintf("At least one feature from model '%s' is not available in other model(s): e.g., '%s'.", + modelID[1], model_features[which(is.na(mapping[ii]))[1]]) + ) + break + } + } # Structuring data for mapping mappingdf <- as.data.frame(mapping, stringsAsFactors = FALSE) @@ -385,10 +396,31 @@ 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% unique(as.vector(as.matrix(sapply(study$results[[model_i]], function(x) x[[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] } diff --git a/inst/tinytest/testPlot.R b/inst/tinytest/testPlot.R index a540d0f..88a8531 100644 --- a/inst/tinytest/testPlot.R +++ b/inst/tinytest/testPlot.R @@ -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( From 7b99ce7d3e2496bc4d1e77f03fd2d2a9e53d0a71 Mon Sep 17 00:00:00 2001 From: Rocha Curado Date: Wed, 26 Jun 2024 10:39:36 +0200 Subject: [PATCH 2/6] implementing changes in feature handling as described in IPAD-512; (1) for multimodel, trigger message if at least one feature is available only in selected model, (2) error message if at least one feature is not found in results obj for single model plots --- R/plots.R | 17 +++++++++++++---- inst/tinytest/testPlot.R | 4 ++-- 2 files changed, 15 insertions(+), 6 deletions(-) diff --git a/R/plots.R b/R/plots.R index 20fc6ed..39c24f2 100644 --- a/R/plots.R +++ b/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.", 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 selected features list contains features available in the selected model '%s' only.", + modelID[1] ) ) } @@ -269,7 +278,7 @@ getMappingPlottingData <- function(study = study, modelID = modelID, featureID = for (ii in colnames(mapping)) { if (ii == modelID[1]) next if (any(is.na(mapping[ii]))) { - message( + warning( sprintf("At least one feature from model '%s' is not available in other model(s): e.g., '%s'.", modelID[1], model_features[which(is.na(mapping[ii]))[1]]) ) diff --git a/inst/tinytest/testPlot.R b/inst/tinytest/testPlot.R index 88a8531..28a0995 100644 --- a/inst/tinytest/testPlot.R +++ b/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,7 +233,7 @@ 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, From e2c8a9d5ccc3204b70fe302d2bce047bb47afe0a Mon Sep 17 00:00:00 2001 From: "Rocha Curado, Marco" Date: Mon, 15 Jul 2024 11:13:08 +0200 Subject: [PATCH 3/6] implementing changes on warning messages for multimodel plots --- R/plots.R | 20 ++++++++++++-------- inst/tinytest/testPlot.R | 10 +++++----- 2 files changed, 17 insertions(+), 13 deletions(-) diff --git a/R/plots.R b/R/plots.R index 39c24f2..a773c75 100644 --- a/R/plots.R +++ b/R/plots.R @@ -248,7 +248,7 @@ getMappingPlottingData <- function(study = study, modelID = modelID, featureID = if (!all(featureID %in% model_features)) { 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] ) ) @@ -260,7 +260,7 @@ getMappingPlottingData <- function(study = study, modelID = modelID, featureID = if (nrow(secondary_features) == 0) { stop( sprintf( - "The selected features list contains features available in the selected model '%s' only.", + "The features are only present in the first model passed, '%s'.", modelID[1] ) ) @@ -275,16 +275,21 @@ getMappingPlottingData <- function(study = study, modelID = modelID, featureID = ) } # 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]))) { - warning( - sprintf("At least one feature from model '%s' is not available in other model(s): e.g., '%s'.", - modelID[1], model_features[which(is.na(mapping[ii]))[1]]) - ) - break + 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) @@ -416,7 +421,6 @@ getPlottingData <- function(study, modelID, featureID, testID = NULL, libraries featID_tmp <- unique(c(featID_tmp, tmp[[1]])) } } - # featureIDAvailable <- featureID %in% unique(as.vector(as.matrix(sapply(study$results[[model_i]], function(x) x[[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\"", diff --git a/inst/tinytest/testPlot.R b/inst/tinytest/testPlot.R index 28a0995..5e75b63 100644 --- a/inst/tinytest/testPlot.R +++ b/inst/tinytest/testPlot.R @@ -241,7 +241,7 @@ expect_error_xl( 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( @@ -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") @@ -575,12 +575,12 @@ 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") From a34daad1aade6d7aa4aebd356543aae966cfb41a Mon Sep 17 00:00:00 2001 From: "Rocha Curado, Marco" Date: Mon, 5 Aug 2024 13:35:17 +0200 Subject: [PATCH 4/6] added regular expression to capture only the model name from grep call in validateMapping --- R/validate.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/validate.R b/R/validate.R index 093f756..dbb6bf8 100644 --- a/R/validate.R +++ b/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)) From 80833f0eed4bd45cf589e18fda4bf93e07d7d2b2 Mon Sep 17 00:00:00 2001 From: Rocha Curado Date: Wed, 21 Aug 2024 14:35:04 +0200 Subject: [PATCH 5/6] warning message when multitest multimodel has at least one test not available across all models --- R/plots.R | 48 ++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 44 insertions(+), 4 deletions(-) diff --git a/R/plots.R b/R/plots.R index a773c75..54184e0 100644 --- a/R/plots.R +++ b/R/plots.R @@ -387,6 +387,34 @@ getPlottingData <- function(study, modelID, featureID, testID = NULL, libraries mapping_features <- mappingPlottingData$mapping_features testID_all <- mappingPlottingData$testID_all modelID <- mappingPlottingData$modelID + + # Warning if at least one test from modelID[1] is not available in secondary models + incomplete_test_matches_sec_models = NULL + incomplete_test_matches = list() + current_model_tests <- names(study$tests[[modelID[1]]])[names(study$tests[[modelID[1]]]) %in% testID] + for (ii in unique(modelID)) { + if (ii == modelID[1]) next + secondary_model_tests <- names(study$tests[[ii]])[names(study$tests[[ii]]) %in% testID] + 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], + # paste(names(study$tests[[modelID[1]]])[!incomplete_test_matches_sec_models], collapse=', ') + unmatched_tests) + ) + } } for (ii in 1:length(modelID)) { @@ -468,6 +496,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)) } @@ -491,13 +529,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)) { From cc085f63cff6a851a9ce7f4e0ed552f00b43978e Mon Sep 17 00:00:00 2001 From: Rocha Curado Date: Wed, 21 Aug 2024 17:28:22 +0200 Subject: [PATCH 6/6] expanded on warning messages on inconsistent testID between primary and secondary models --- R/plots.R | 27 +++++++++++++++++++++++---- inst/tinytest/testPlot.R | 2 +- 2 files changed, 24 insertions(+), 5 deletions(-) diff --git a/R/plots.R b/R/plots.R index 54184e0..0a197b4 100644 --- a/R/plots.R +++ b/R/plots.R @@ -388,13 +388,31 @@ getPlottingData <- function(study, modelID, featureID, testID = NULL, libraries testID_all <- mappingPlottingData$testID_all modelID <- mappingPlottingData$modelID - # Warning if at least one test from modelID[1] is not available in secondary models + # 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 <- names(study$tests[[modelID[1]]])[names(study$tests[[modelID[1]]]) %in% testID] + 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 <- names(study$tests[[ii]])[names(study$tests[[ii]]) %in% testID] + 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 @@ -402,6 +420,8 @@ getPlottingData <- function(study, modelID, featureID, testID = NULL, libraries 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)) { @@ -411,7 +431,6 @@ getPlottingData <- function(study, modelID, featureID, testID = NULL, libraries warning( sprintf("At least one test from model '%s' is not available in other model(s). Test(s) impacted: %s", modelID[1], - # paste(names(study$tests[[modelID[1]]])[!incomplete_test_matches_sec_models], collapse=', ') unmatched_tests) ) } diff --git a/inst/tinytest/testPlot.R b/inst/tinytest/testPlot.R index 5e75b63..f9d0854 100644 --- a/inst/tinytest/testPlot.R +++ b/inst/tinytest/testPlot.R @@ -569,7 +569,7 @@ expect_true_xl( rm(plottingData) -# getPlottingData (package, multiModel) ----------------------------------------- +# getPlottingData (package, multiModel) ---------------------------------------- mmodel <- names(testStudyObj[["models"]])[1:2] mmtestID <- c("test_01", "test_02")