Support multiple transformations of assays and metaAssays per model

DESCRIPTION

@@ -11,7 +11,7 @@ Description:
   deployed online to be explored by collaborators. The dashboard includes
   'sortable' tables, interactive plots including network visualization, and
   fine-grained filtering based on statistical significance.
-Version: 1.19.0
+Version: 1.19.0.1
 Authors@R: c(
   person("Terrence", "Ernst", role = c("aut"),
          comment = "Web application"),

R/add.R

@@ -248,6 +248,15 @@ addModels <- function(study, models, reset = FALSE) {
 
 #' Add assays
 #'
+#' Add assays to the models of an OmicNavigator study.
+#'
+#' If you want to add multiple transformations of your assays for a given
+#' modelID, you can add another layer of nesting. Instead of passing a data
+#' frame for that modelID, you can pass a named list of data frames. Each
+#' transformation should have identical row and column names. If your data
+#' doesn't fit this restriction, you should probably use multiple models
+#' instead.
+#'
 #' @param assays The assays from the study. The input object is a list of data
 #'   frames (one per model). The row names should correspond to the featureIDs
 #'   (\code{\link{addFeatures}}). The column names should correspond to the
@@ -715,6 +724,13 @@ addMetaFeaturesLinkouts <- function(study, metaFeaturesLinkouts, reset = FALSE)
 #' Experimental. Add metaAssay measurements that map to the metaFeatureIDs in
 #' the metaFeatures table.
 #'
+#' If you want to add multiple transformations of your metaAssays for a given
+#' modelID, you can add another layer of nesting. Instead of passing a data
+#' frame for that modelID, you can pass a named list of data frames. Each
+#' transformation should have identical row and column names. If your data
+#' doesn't fit this restriction, you should probably use multiple models
+#' instead.
+#'
 #' @param metaAssays The metaAssays from the study. The input object is a list
 #'   of data frames (one per model). The row names should correspond to the
 #'   metaFeatureIDs (second column of data frame added via

R/check.R

@@ -259,26 +259,51 @@ checkModels <- function(models) {
 checkAssays <- function(assays) {
   checkList(assays)
 
+  # modelID cannot have --- because this is used in filenames to separate
+  # transformations
+  stopIfDashes(names(assays))
+
   for (i in seq_along(assays)) {
-    stopifnot(
-      inherits(assays[[i]], "data.frame"),
-      nrow(assays[[i]]) > 0,
-      ncol(assays[[i]]) > 0
-    )
-    # Warn if row names are unlikely to be the featureIDs
-    rows <- row.names(assays[[i]])
-    if (identical(rows, as.character(seq_along(rows)))) {
-      warning(
-        "The row names of the assays data frame should be the featureIDs.\n",
-        sprintf("Problematic modelID: %s", names(assays)[i])
+    if (isList(assays[[i]])) {
+      # support multiple transformations
+      checkList(assays[[i]])
+      stopIfDashes(names(assays[[i]]))
+      for (j in seq_along(assays[[i]])) {
+        checkAssaysDataFrame(
+          assaysDataFrame = assays[[i]][[j]],
+          modelID = names(assays)[i]
+        )
+      }
+    } else {
+      checkAssaysDataFrame(
+        assaysDataFrame = assays[[i]],
+        modelID = names(assays)[i]
       )
     }
-    # All the columns must be numeric
-    colsAllNum <- all(vapply(assays[[i]], is.numeric, logical(1)))
-    if (!colsAllNum) {
-      stop("The columns of the assays data frame must all be numeric.\n",
-           sprintf("Problematic modelID: %s", names(assays)[i]))
-    }
+  }
+
+  return(NULL)
+}
+
+checkAssaysDataFrame <- function(assaysDataFrame, modelID) {
+  stopifnot(
+    inherits(assaysDataFrame, "data.frame"),
+    nrow(assaysDataFrame) > 0,
+    ncol(assaysDataFrame) > 0
+  )
+  # Warn if row names are unlikely to be the featureIDs
+  rows <- row.names(assaysDataFrame)
+  if (identical(rows, as.character(seq_along(rows)))) {
+    warning(
+      "The row names of the assays data frame should be the featureIDs.\n",
+      sprintf("Problematic modelID: %s", modelID)
+    )
+  }
+  # All the columns must be numeric
+  colsAllNum <- all(vapply(assaysDataFrame, is.numeric, logical(1)))
+  if (!colsAllNum) {
+    stop("The columns of the assays data frame must all be numeric.\n",
+         sprintf("Problematic modelID: %s", modelID))
   }
 
   return(NULL)
@@ -287,23 +312,48 @@ checkAssays <- function(assays) {
 checkMetaAssays <- function(metaAssays) {
   checkList(metaAssays)
 
+  # modelID cannot have --- because this is used in filenames to separate
+  # transformations
+  stopIfDashes(names(metaAssays))
+
   for (i in seq_along(metaAssays)) {
-    stopifnot(
-      inherits(metaAssays[[i]], "data.frame"),
-      nrow(metaAssays[[i]]) > 0,
-      ncol(metaAssays[[i]]) > 0
-    )
-    # All the columns must be numeric
-    colsAllNum <- all(vapply(metaAssays[[i]], is.numeric, logical(1)))
-    if (!colsAllNum) {
-      stop("The columns of the metaAssays data frame must all be numeric.\n",
-           sprintf("Problematic modelID: %s", names(metaAssays)[i]))
+    if (isList(metaAssays[[i]])) {
+      # support multiple transformations
+      checkList(metaAssays[[i]])
+      stopIfDashes(names(metaAssays[[i]]))
+      for (j in seq_along(metaAssays[[i]])) {
+        checkMetaAssaysDataFrame(
+          metaAssaysDataFrame = metaAssays[[i]][[j]],
+          modelID = names(metaAssays)[i]
+        )
+      }
+    } else {
+      checkMetaAssaysDataFrame(
+        metaAssaysDataFrame = metaAssays[[i]],
+        modelID = names(metaAssays)[i]
+      )
     }
   }
 
   return(NULL)
 }
 
+checkMetaAssaysDataFrame <- function(metaAssaysDataFrame, modelID) {
+  stopifnot(
+    inherits(metaAssaysDataFrame, "data.frame"),
+    nrow(metaAssaysDataFrame) > 0,
+    ncol(metaAssaysDataFrame) > 0
+  )
+  # All the columns must be numeric
+  colsAllNum <- all(vapply(metaAssaysDataFrame, is.numeric, logical(1)))
+  if (!colsAllNum) {
+    stop("The columns of the metaAssays data frame must all be numeric.\n",
+         sprintf("Problematic modelID: %s", modelID))
+  }
+
+  return(NULL)
+}
+
 checkTests <- function(tests) {
   checkList(tests)
 

R/export.R

@@ -165,8 +165,16 @@ exportElementsWrite <- function(
   for (i in seq_along(x)) {
     fileName <- file.path(path, names(x)[i])
     if (fileType == "txt") {
-      fileName <- paste0(fileName, ".txt")
-      writeTable(x[[i]], file = fileName, row.names = hasRowNames)
+      if (isList(x[[i]])) {
+        # Support multiple data frames per modelID
+        for (j in seq_along(x[[i]])) {
+          fileNameJ <- paste0(fileName, "---", names(x[[i]])[j], ".txt")
+          writeTable(x[[i]][[j]], file = fileNameJ, row.names = hasRowNames)
+        }
+      } else {
+        fileName <- paste0(fileName, ".txt")
+        writeTable(x[[i]], file = fileName, row.names = hasRowNames)
+      }
     } else if (fileType == "json") {
       fileName <- paste0(fileName, ".json")
       writeJson(x[[i]], file = fileName, ...)

R/get.R

@@ -550,6 +550,10 @@ getElements.character <- function(
     return(list())
   }
 
+  if (elements %in% c("assays", "metaAssays")) {
+    elementsFiles <- supportAssaysTransformations(elementsFiles)
+  }
+
   filters <- Filter(function(x) !is.null(x), filters)
 
   for (i in seq_along(filters)) {
@@ -596,3 +600,22 @@ getFiles <- function(path, fileType = "txt") {
     path
   }
 }
+
+# If an id/filename contains triple dashes (---), add another level of nesting
+supportAssaysTransformations <- function(x) {
+  if (!any(grepl("---", names(x)))) return(x)
+
+  splits <- strsplit(names(x), split = "---")
+  models <- vapply(splits, function(e) e[1], character(1))
+  result <- vector("list", length = length(unique(models)))
+  names(result) <- unique(models)
+  for (i in seq_along(splits)) {
+    if (length(splits[[i]]) == 1) {
+      result[[ splits[[i]] ]] <- x[[i]]
+    } else {
+      result[[ splits[[i]][[1]] ]][[ splits[[i]][[2]] ]] <- x[[i]]
+    }
+  }
+
+  return(result)
+}

R/plots.R

@@ -320,7 +320,8 @@ getMappingPlottingData <- function(study = study, modelID = modelID, featureID =
 #'   filtered to only include the row(s) corresponding to the input featureID(s)
 #'   (see \code{\link{getAssays}}). If multiple featureIDs are requested, the
 #'   rows are reordered to match the order of this input. The column order is
-#'   unchanged.}
+#'   unchanged. If there are multiple transformations available, the full list
+#'   of filtered data frames is returned.}
 #'
 #'   \item{\code{samples}}{A data frame that contains the sample metadata for
 #'   the given modelID (see \code{\link{getSamples}}). The rows are reordered to
@@ -354,7 +355,8 @@ getMappingPlottingData <- function(study = study, modelID = modelID, featureID =
 #'   measurements, filtered to only include the row(s) corresponding to the
 #'   input featureID(s) (see \code{\link{getMetaAssays}}). If multiple
 #'   featureIDs are requested, the rows are reordered to match the order of this
-#'   input. The column order is unchanged.}
+#'   input. The column order is unchanged. If there are multiple transformations
+#'   available, the full list of filtered data frames is returned.}
 #'
 #' If the study has objects available that map to the input modelID(s),
 #' then \code{objects} is returned. It is not possible to filter by featureID(s)
@@ -413,22 +415,36 @@ 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))
+      if (isList(assays)) {
+        featureIDAvailable <- featureID %in% row.names(assays[[1]])
+        if (any(!featureIDAvailable)) {
+          stop(sprintf("The feature \"%s\" is not available for modelID \"%s\"",
+                       featureID[!featureIDAvailable][1], model_i))
+        }
+        assaysPlotting <- lapply(assays, function(x) x[featureID, , drop = FALSE])
+      } else {
+        featureIDAvailable <- featureID %in% row.names(assays)
+        if (any(!featureIDAvailable)) {
+          stop(sprintf("The feature \"%s\" is not available for modelID \"%s\"",
+                       featureID[!featureIDAvailable][1], model_i))
+        }
+        assaysPlotting <- assays[featureID, , drop = FALSE]
       }
-      assaysPlotting <- assays[featureID, , drop = FALSE]
     }
 
     samples <- getSamples(study, modelID = model_i, quiet = TRUE,
                           libraries = libraries)
     if (isEmpty(samples) || isEmpty(assays)) {
       samplesPlotting <- samples
     } else {
-      samplesPlotting <- samples[match(colnames(assaysPlotting), samples[[1]], nomatch = 0), ,
+      if (isList(assaysPlotting)) {
+        sampleID <- colnames(assaysPlotting[[1]])
+      } else {
+        sampleID <- colnames(assaysPlotting)
+      }
+      samplesPlotting <- samples[match(sampleID, samples[[1]], nomatch = 0), ,
                                  drop = FALSE]
-      if (!identical(samplesPlotting[[1]], colnames(assaysPlotting))) {
+      if (!identical(samplesPlotting[[1]], sampleID)) {
         warning("Not all of the sampleIDs have metadata")
       }
       row.names(samplesPlotting) <- NULL # reset row numbers after filtering
@@ -463,9 +479,16 @@ getPlottingData <- function(study, modelID, featureID, testID = NULL, libraries
     if (isEmpty(metaAssays)) {
       metaAssaysPlotting <- metaAssays
     } else {
-      metaAssaysPlotting <- metaAssays[unique(metaFeaturesPlotting[[2]]), , drop = FALSE]
-      if (nrow(metaAssaysPlotting) == 0) {
-        warning(sprintf("Could not find metaAssays for featureID \"%s\"", featureID))
+      if (isList(metaAssays)) {
+        metaAssaysPlotting <- lapply(
+          metaAssays,
+          function(x) x[unique(metaFeaturesPlotting[[2]]), , drop = FALSE]
+        )
+      } else {
+        metaAssaysPlotting <- metaAssays[unique(metaFeaturesPlotting[[2]]), , drop = FALSE]
+        if (nrow(metaAssaysPlotting) == 0) {
+          warning(sprintf("Could not find metaAssays for featureID \"%s\"", featureID))
+        }
       }
     }
 

R/sanitize.R

@@ -24,7 +24,14 @@ sanitizeModels <- function(models) {
 
 sanitizeAssays <- function(assays) {
   for (i in seq_along(assays)) {
-    assays[[i]] <- as.data.frame(assays[[i]])
+    if (isList(assays[[i]])) {
+      # support multiple transformations
+      for (j in seq_along(assays[[i]])) {
+        assays[[i]][[j]] <- as.data.frame(assays[[i]][[j]])
+      }
+    } else {
+      assays[[i]] <- as.data.frame(assays[[i]])
+    }
   }
 
   return(assays)
@@ -119,6 +126,17 @@ sanitizeMetaFeaturesLinkouts <- function(metaFeaturesLinkouts) {
 }
 
 sanitizeMetaAssays <- function(metaAssays) {
+  for (i in seq_along(metaAssays)) {
+    if (isList(metaAssays[[i]])) {
+      # support multiple transformations
+      for (j in seq_along(metaAssays[[i]])) {
+        metaAssays[[i]][[j]] <- as.data.frame(metaAssays[[i]][[j]])
+      }
+    } else {
+      metaAssays[[i]] <- as.data.frame(metaAssays[[i]])
+    }
+  }
+
   return(metaAssays)
 }
 

R/utility.R

@@ -106,6 +106,12 @@ writeJson <- function(x, file, auto_unbox = TRUE, pretty = TRUE, ...) {
 
 isEmpty <- function(x) {length(x) == 0}
 
+# Required to differentiate between a list and a data frame because is.list()
+# returns TRUE for a data frame. Note that this is much more stringent than
+# is.list() because it requires the object to be assigned the class "list",
+# which for example, a typical S3 object like "ONstudy" does not have.
+isList <- function(x) inherits(x, "list")
+
 combineListIntoTable <- function(listObj, newColumnName = "newColumnName") {
   stopifnot(
     is.list(listObj),
@@ -205,6 +211,16 @@ capitalize <- function(x) {
   return(final)
 }
 
+stopIfDashes <- function(x) {
+  invalidDashes <- grepl("---", x)
+  if (any(invalidDashes)) {
+    stop(
+      "Names cannot include triple dashes (---): ",
+      paste(x[invalidDashes], collapse = ", ")
+    )
+  }
+}
+
 # Filesystem -------------------------------------------------------------------
 
 # Rename file by first copying and then deleting original