addMapping() to support future multi-model plotting

NAMESPACE

@@ -11,6 +11,7 @@ export(addBarcodes)
 export(addEnrichments)
 export(addEnrichmentsLinkouts)
 export(addFeatures)
+export(addMapping)
 export(addMetaFeatures)
 export(addMetaFeaturesLinkouts)
 export(addModels)
@@ -37,6 +38,7 @@ export(getFavicons)
 export(getFeatures)
 export(getInstalledStudies)
 export(getLinkFeatures)
+export(getMapping)
 export(getMetaFeatures)
 export(getMetaFeaturesLinkouts)
 export(getMetaFeaturesTable)

R/add.R

@@ -31,6 +31,7 @@
 #' @inheritParams addEnrichments
 #' @inheritParams addMetaFeatures
 #' @inheritParams addPlots
+#' @inheritParams addMapping
 #' @inheritParams addBarcodes
 #' @inheritParams addReports
 #' @inheritParams addResultsLinkouts
@@ -51,6 +52,7 @@
 #'   \code{\link{addEnrichments}},
 #'   \code{\link{addMetaFeatures}},
 #'   \code{\link{addPlots}},
+#'   \code{\link{addMapping}},
 #'   \code{\link{addBarcodes}},
 #'   \code{\link{addReports}},
 #'   \code{\link{addResultsLinkouts}},
@@ -86,6 +88,7 @@ createStudy <- function(name,
                         enrichments = list(),
                         metaFeatures = list(),
                         plots = list(),
+                        mapping = list(),
                         barcodes = list(),
                         reports = list(),
                         resultsLinkouts = list(),
@@ -115,6 +118,7 @@ createStudy <- function(name,
                 enrichments = list(),
                 metaFeatures = list(),
                 plots = list(),
+                mapping = list(),
                 barcodes = list(),
                 reports = list(),
                 resultsLinkouts = list(),
@@ -137,6 +141,7 @@ createStudy <- function(name,
   study <- addEnrichments(study, enrichments = enrichments)
   study <- addMetaFeatures(study, metaFeatures = metaFeatures)
   study <- addPlots(study, plots = plots)
+  study <- addMapping(study, mapping = mapping)
   study <- addBarcodes(study, barcodes = barcodes)
   study <- addReports(study, reports = reports)
   study <- addResultsLinkouts(study, resultsLinkouts = resultsLinkouts)
@@ -387,8 +392,8 @@ addMetaFeatures <- function(study, metaFeatures, reset = FALSE) {
 #'   required metadata element is \code{displayName}, which controls how the
 #'   plot will be named in the app. You are encouraged to also specify the
 #'   \code{plotType}, e.g. \code{"singleFeature"}, \code{"multiFeature"},
-#'   \code{"multiTest"}. Note that PlotType accepts a vector of entries,
-#'   whenever applicable, e.g., plotType = c(\code{"multiFeature"},
+#'   \code{"multiTest"}, \code{"multiModel"}. PlotType accepts vector of
+#'   entries, whenever applicable, e.g., plotType = c(\code{"multiFeature"},
 #'   \code{"multiTest"}). If you do not specify the \code{plotType}, the plot
 #'   will be assumed to be \code{"singleFeature"} and \code{"singleTest"}.
 #'   Optionally, if the plotting function requires external packages, these can
@@ -403,6 +408,34 @@ addPlots <- function(study, plots, reset = FALSE) {
   addElements(study, plots, reset)
 }
 
+#' Add mapping object
+#'
+#' Includes a mapping list connecting features across models.
+#'
+#' Mapping object consists of a list with element names matching the model
+#' names, and each element consisting in a vector with feature IDs found in the
+#' result object. For making meaningful connections between models, feature IDs
+#' for distinct models must be aligned per index position in the vector.
+#' E.g., if in a study there are models "transcriptomics" and "proteomics" and
+#' the user wants to create a plot based on data from both, a mapping list with
+#' element names "transcriptomics" and "proteomics" should be created, where
+#' feature IDs of both models are found in the same index position in each list
+#' element.
+#'
+#' @param mapping Feature IDs from models. The input object is a list object
+#'   with element names matching model names, and each element containing a
+#'   vector with feature IDs per model. Features with same index position across
+#'   models are considered found across models. For each model, the feature IDs
+#'   must match the feature IDs from results object of the respective model.
+#' @inherit shared-add
+#'
+#' @seealso \code{\link{getPlottingData}}, \code{\link{plotStudy}}
+#'
+#' @export
+addMapping <- function(study, mapping, reset = FALSE) {
+  addElements(study, mapping, reset)
+}
+
 #' Add barcode plot metadata
 #'
 #' The app can display a barcode plot of the enrichment results for a given

R/check.R

@@ -402,6 +402,39 @@ checkPlots <- function(plots) {
   return(NULL)
 }
 
+checkMapping <- function(mapping) {
+  checkList(mapping)
+
+  # stop if mapping object has less than 2 elements
+  if (length(mapping) > 0) stopifnot(length(mapping) > 1)
+  else return(NULL)
+
+  # check if list elements have the same size. If not, fill difference with NA.
+  listMaxLength <- max(sapply(mapping, length))
+  mapping <- lapply(lapply(mapping, unlist), "length<-", listMaxLength)
+
+  mappingdf <- as.data.frame(mapping)
+
+  # NAs are accepted, but not if all values for a model are NA
+  stopifnot(vapply(mappingdf, is.character, logical(1)))
+
+  # check if any given model has at least one feature aligned with another model
+  for (i in seq_along(mappingdf)) {
+    tempModel   <- mappingdf[!is.na(mappingdf[[i]]),]
+    if (nrow(tempModel) > 1) {
+      featAligned <- any(apply(!sapply(tempModel, is.na), 1, sum) > 1)
+    } else {
+      featAligned <- any(sum(!sapply(tempModel, is.na)) > 1)
+    }
+
+    if (isFALSE(featAligned)) {
+      stop(sprintf("Model \"%s\" does not present any feature mapping to another model.", colnames(mappingdf)[[i]]))
+    }
+  }
+
+  return(NULL)
+}
+
 checkBarcodes <- function(barcodes) {
   checkList(barcodes)
 

R/get.R

@@ -266,6 +266,24 @@ getPlots <- function(study, modelID = NULL, quiet = FALSE, libraries = NULL) {
   )
 }
 
+#' Get mapping object from a study
+#'
+#' @inherit shared-get
+#' @inheritParams listStudies
+#'
+#' @export
+getMapping <- function(study, quiet = FALSE, libraries = NULL) {
+  getElements(
+    study,
+    elements = "mapping",
+    filters = list(),
+    default = "default",
+    fileType = "json",
+    quiet = quiet,
+    libraries = libraries
+  )
+}
+
 #' Get barcodes from a study
 #'
 #' @inherit shared-get

R/sanitize.R

@@ -74,6 +74,10 @@ sanitizePlots <- function(plots) {
   return(plots)
 }
 
+sanitizeMapping <- function(mapping) {
+  return(mapping)
+}
+
 sanitizeBarcodes <- function(barcodes) {
   return(barcodes)
 }

R/tests.R

@@ -32,6 +32,8 @@ testStudy <- function(name,
                        resultsLinkouts = testResultsLinkouts(),
                        enrichmentsLinkouts = testEnrichmentsLinkouts(),
                        metaFeaturesLinkouts = testMetaFeaturesLinkouts(),
+                       mapping = testMapping(seed = seed, nFeatures = nFeatures,
+                                             numericFeatureID = numericFeatureID),
                        version = version,
                        maintainer = maintainer,
                        maintainerEmail = maintainerEmail,
@@ -326,6 +328,31 @@ testPlots <- function() {
   return(plots)
 }
 
+testMapping <- function(seed = 12345L, nFeatures = 100,
+                        numericFeatureID = FALSE) {
+
+  results <- testResults(seed = seed, nFeatures = nFeatures,
+                         numericFeatureID = numericFeatureID)
+
+  model_01_feats <- results[[1]][[1]][,1]
+  model_02_feats <- results[[2]][[1]][,1]
+
+  model_01_feats <- model_01_feats[order(model_01_feats)]
+  model_02_feats <- model_02_feats[order(model_02_feats)]
+
+  set.seed(1)
+  model_01_feats[which(model_01_feats %in% sample(model_01_feats, 10))] <- NA
+  set.seed(2)
+  model_02_feats[which(model_02_feats %in% sample(model_02_feats, 10))] <- NA
+
+  mapping <- list(
+    model_01 = model_01_feats,
+    model_02 = model_02_feats
+  )
+
+  return(mapping)
+}
+
 testBarcodes <- function(n = 3) {
   barcodes <- list(
     default = list(

R/validate.R

@@ -23,6 +23,7 @@ validateStudy <- function(study) {
   validateEnrichments(study)
   validateEnrichmentsLinkouts(study)
   validatePlots(study)
+  validateMapping(study)
 
   return(invisible(TRUE))
 }
@@ -312,3 +313,34 @@ validatePlots <- function(study) {
 
   return(invisible(TRUE))
 }
+
+validateMapping <- function(study) {
+  mapping <- study[["mapping"]]
+
+  # Mapping isn't required
+  if (isEmpty(mapping)) return(NA)
+
+  # Check whether mapping names match model names from results table
+  models <- names(study[["results"]])
+  for (i in seq_along(mapping)) {
+    mappingID <- names(mapping[i])
+    if (!mappingID %in% models) {
+      stop("At least one mapping name does not match any model name from results table\n",
+           sprintf("mappingID: %s", mappingID))
+    }
+  }
+
+  # Check whether mapping features match results features
+  results <- getResults(study)
+  for (i in seq_along(mapping)) {
+    mappingID <- names(mapping[i])
+    mappingFeatures <- mapping[[i]][which(!is.na(mapping[[i]]))]
+    modelFeatures   <- results[[grep(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))
+    }
+  }
+  return(invisible(TRUE))
+}
+

inst/tinytest/testAdd.R

@@ -2,6 +2,7 @@
 
 # Setup ------------------------------------------------------------------------
 
+# source(paste0(getwd(), "/inst/tinytest/tinytestSettings.R"))
 source("tinytestSettings.R")
 using(ttdo)
 
@@ -44,6 +45,9 @@ study <- addMetaFeatures(study, metaFeatures = metaFeatures)
 barcodes <- OmicNavigator:::testBarcodes()
 study <- addBarcodes(study, barcodes = barcodes)
 
+mapping <- OmicNavigator:::testMapping()
+study <- addMapping(study, mapping = mapping)
+
 reports <- OmicNavigator:::testReports()
 study <- addReports(study, reports = reports)
 

inst/tinytest/testCheck.R

@@ -447,6 +447,45 @@ if (getRversion() > "4") {
   )
 }
 
+# checkMapping -----------------------------------------------------------------
+
+expect_error_xl(
+  addMapping(study, mapping = NULL)
+)
+
+## add checks based on check.R
+tempMapping <- list(model_01 = c("feature_01", "feature_02"),
+                    model_02 = c("feature_01", NA))
+expect_silent_xl(
+  addMapping(study, mapping = tempMapping)
+)
+
+tempMapping <- list(model_01 = c("feature_01", "feature_02"),
+                    model_02 = c(NA, NA))
+expect_error_xl(
+  addMapping(study, mapping = tempMapping)
+)
+
+# check mapping with distinct sizes for elements
+tempMapping <- list(model_01 = c("feature_01", "feature_02"),
+                    model_02 = c("feature_01"))
+expect_silent_xl(
+  addMapping(study, mapping = tempMapping)
+)
+
+# check mapping with one single element
+tempMapping <- list(model_01 = c("feature_01", "feature_02"))
+expect_error_xl(
+  addMapping(study, mapping = tempMapping)
+)
+
+# check mapping features that do not match across models
+tempMapping <- list(model_01 = c("feature_01", "feature_02", NA, NA),
+                    model_02 = c(NA, NA, "feature_05", "feature_06"))
+expect_error_xl(
+  addMapping(study, mapping = tempMapping)
+)
+
 # checkBarcodes ----------------------------------------------------------------
 
 expect_error_xl(

inst/tinytest/testGet.R

@@ -2,6 +2,7 @@
 
 # Setup ------------------------------------------------------------------------
 
+# source(paste0(getwd(), "/inst/tinytest/tinytestSettings.R"))
 source("tinytestSettings.R")
 using(ttdo)
 
@@ -597,6 +598,28 @@ expect_identical_xl(
   testStudyObj[["plots"]][["model_03"]]
 )
 
+# getMapping -------------------------------------------------------------------
+
+expect_identical_xl(
+  getMapping(testStudyObj),
+  testStudyObj[["mapping"]]
+)
+
+expect_message_xl(
+  getMapping(emptyStudy),
+  "No mapping available"
+)
+
+expect_error_xl(
+  getMapping(1),
+  "No method for object of class \"numeric\""
+)
+
+expect_error_xl(
+  getMapping(data.frame()),
+  "No method for object of class \"data.frame\""
+)
+
 # getBarcodes ------------------------------------------------------------------
 
 expect_identical_xl(

inst/tinytest/testGetNumeric.R

@@ -146,6 +146,19 @@ expect_true_xl(
   )
 )
 
+# getMapping -------------------------------------------------------------------
+
+expect_identical_xl(
+  getMapping(testStudyObj),
+  testStudyObj[["mapping"]]
+)
+
+expect_true_xl(
+  is.character(
+    unlist(getMapping(testStudyObj))
+  )
+)
+
 # getBarcodeData ---------------------------------------------------------------
 
 barcodeDataFromR <- getBarcodeData(