Minor fix to subset.loom, added more to add.cells
authorPaul Hoffman <phoffman@nygenome.org>
Tue, 2 Jan 2018 23:58:25 +0000 (18:58 -0500)
committerPaul Hoffman <phoffman@nygenome.org>
Tue, 2 Jan 2018 23:58:25 +0000 (18:58 -0500)
Adding cells should work, haven't tested it yet so I can't say for sure

R/internal.R
R/loom.R
man/loom-class.Rd

index 52018ba16d695977ecfdbfeea7cb719d7b552abc..1b7d8ac9b8e189da51aa20668f498f5aff395b0a 100644 (file)
@@ -57,3 +57,255 @@ validateLoom <- function(object) {
     }
   }
 }
+
+# A function to determine if a vector is a vector and not a list
+#
+# @param x An object
+#
+# @return TRUE if 'x' is a vector or a factor, otherwise FALSE
+#
+is.actual_vector <- function(x) {
+  return((is.vector(x = x) || is.factor(x = x)) && !is.list(x = x))
+}
+
+# Check additions to /matrix
+#
+# @param x A list of vectors to add to /matrix
+# @param n The number of genes needed in each cell
+#
+# @return 'x' as a list of vectors
+#
+check.matrix_data <- function(x, n) {
+  # Coerce x into a list, where each
+  # entry in the list is a new cell added
+  if (is.actual_vector(x = x)) {
+    x <- list(x)
+  } else if (is.matrix(x = x) || is.data.frame(x = x)) {
+    x <- as.list(x = x)
+  }
+  if (!is.list(x = x)) {
+    stop("Matrix data must be a list of vectors")
+  }
+  # Ensure that each entry in the list is a vector of length n
+  vector.check <- vapply(
+    X = x,
+    FUN = is.actual_vector,
+    FUN.VALUE = logical(length = 1L)
+  )
+  if (!all(vector.check)) {
+    stop('Each new cell added must be represented as a vector')
+  }
+  # Ensure each new cell added has data for the number of genes present
+  for (i in 1:length(x = x)) {
+    cell.add <- x[[i]]
+    if (length(x = cell.add) > n) {
+      stop(paste(
+        "Cannot add genes to a loom file, the maximum number of genes allowed is",
+        n
+      ))
+    } else if (length(x = cell.add) < n) {
+      cell.add[(length(x = cell.add) + 1):n] <- NA
+    }
+    x[[i]] <- cell.add
+  }
+  return(x)
+}
+
+# Get the number of cells being added to /matrix
+#
+# @param x A list of vectors to add to /matrix
+#
+# @return The number of cells in x
+#
+nCells.matrix_data <- function(x) {
+  return(length(x = x))
+}
+
+# Add missing cells to data added to /matrix
+#
+# @param x A list of vectors to add to /matrix
+# @param n The number of genes each cell needs
+# @param m2 The number of cells being added to the loom file
+#
+# @return 'x' with the proper number of cells
+#
+addCells.matrix_data <- function(x, n, m2) {
+  if (length(x = x) < m2) {
+    x[(length(x = x) + 1):m2] <- list(rep.int(x = NA, times = n))
+  }
+  return(x)
+}
+
+# Check additions to /layers
+#
+# @param x A list of matrices to add layers in /layers
+# @param n The number of genes needed for each layer
+# @param layers.names Names found in /layers
+#
+# @return 'x' as a list of matricies with 'n' rows for each layer present in /layers
+#
+check.layers <- function(x, n, layers.names) {
+  # Coerce x into a list of matricies
+  if (is.null(x = x)) {
+    x <- list()
+  } else if (is.matrix(x = x) || is.data.frame(x = x)) {
+    x <- list(as.matrix(x = x))
+  }
+  if (!is.list(x = x)) {
+    stop("Layers data must be a list of matricies")
+  }
+  # Ensure we have enough layer additions for each layer
+  # Manage named lists, taking only those with the same name as in /layers
+  # or is named with an empty string
+  if (!is.null(x = names(x = x))) {
+    x.use <- which(x = names(x = x) %in% layers.names | names(x = x) == '')
+    x <- x[x.use]
+  }
+  if (length(x = x) > length(x = layers.names)) {
+    stop("Cannot add more layers than already present")
+  } else if (length(x = x) < length(x = layers.names)) {
+    x[(length(x = x) + 1):length(x = layers.names)] <- data.frame(rep.int(x = NA, times = n))
+  }
+  # Ensure that we have all genes needed
+  for (i in 1:length(x = x)) {
+    layer <- x[[i]]
+    if (is.data.frame(x = layer)) {
+      layer <- as.matrix(x = layer)
+    } else if (is.actual_vector(x = layer)) {
+      layer <- matrix(data = layer, ncol = 1)
+    }
+    if (!is.matrix(x = layer)) {
+      stop("Layers data must be a list of matrices")
+    }
+    if (nrow(x = layer) > n) {
+      stop(paste(
+        "Cannot add genes to a loom file, the maximum number of genes allowed is",
+        n
+      ))
+    } else if (nrow(x = layer) < n) {
+      layer <- as.data.frame(x = layer)
+      layer[(nrow(x = layer) + 1):n, ] <- NA
+      layer <- as.matrix(x = layer)
+    }
+    x[[i]] <- layer
+  }
+  # Set names
+  x.unnamed <- which(x = !(names(x = x) %in% layers.names))
+  if (length(x = x.unnamed) == 0) {
+    x.unnamed <- 1:length(x = x)
+  }
+  names.unused <- which(x = !(layers.names %in% names(x = x)))
+  names(x = x)[x.unnamed] <- layers.names[names.unused]
+  return(x)
+}
+
+# Get the number of cells being added to /layers
+#
+# @param x A list of matricies to add to /layers
+#
+# @return The number of cells within each matrix
+#
+nCells.layers <- function(x) {
+  return(vapply(X = x, FUN = ncol, FUN.VALUE = integer(length = 1L)))
+}
+
+# Add missing cells to data added to /matrix
+#
+# @param x A list of matricies to add to /layers
+# @param n The number of genes each cell needs
+# @param m2 The number of cells being added to the loom file
+#
+# @return 'x' with the proper number of cells
+#
+addCells.layers <- function(x, n, m2) {
+  layers.extend <- vapply(X = x, FUN = ncol, FUN.VALUE = integer(length = 1L))
+  layers.extend <- which(x = layers.extend != m2)
+  for (i in layers.extend) {
+    layer <- x[[i]]
+    layer.new <- matrix(nrow = n, ncol = m2)
+    layer.new[, 1:ncol(x = layer)] <- layer
+    x[[i]] <- layer.new
+    gc(verbose = FALSE)
+  }
+  return(x)
+}
+
+# Check additions to /col_attrs
+#
+# @param x A list of vectors to add to /col_attrs
+# @param attrs.names Names of attributes found in /col_attrs
+#
+# @return 'x' as a list of vectors for each attribute found in /col_attrs
+#
+check.col_attrs <- function(x, attrs.names) {
+  # Coerce x into a list of vectors
+  if (is.null(x = x)) {
+    x <- list()
+  } else if (is.actual_vector(x = x)) {
+    x <- list(x)
+  } else if (is.matrix(x = x) || is.data.frame(x = x)) {
+    x <- as.list(x = x)
+  }
+  if (!is.list(x = x)) {
+    stop("Attribute data must be a list of vectors")
+  }
+  # Ensure we have enough attribute additions for each col_attr
+  # Manage named lists, taking only those with the same name as in /col_attrs
+  # or is named with an empty string
+  if (!is.null(x = names(x = x))) {
+    x.use <- which(x = names(x = x) %in% attrs.names | names(x = x) == '')
+    x <- x[x.use]
+  }
+  if (length(x = x) > length(x = attrs.names)) {
+    stop("Cannot add more column attributes than already present")
+  } else if (length(x = x) < length(x = attrs.names)) {
+    x[(length(x = x) + 1):length(x = attrs.names)] <- NA
+  }
+  if (!all(vapply(X = x, FUN = is.actual_vector, FUN.VALUE = logical(length = 1L)))) {
+    stop("Attribute data must be a list of vectors")
+  }
+  # Set names
+  x.unnamed <- which(x = !(names(x = x) %in% attrs.names))
+  if (length(x = x.unnamed) == 0) {
+    x.unnamed <- 1:length(x = x)
+  }
+  names.unused <- which(x = !(attrs.names %in% names(x = x)))
+  names(x = x)[x.unnamed] <- attrs.names[names.unused]
+  return(x)
+}
+
+# Get the number of cells being added to /col_attrs
+#
+# @param x A list of vectors to add to /col_attrs
+#
+# @return The number of cells for each attribute
+#
+nCells.col_attrs <- function(x) {
+  return(vapply(X = x, FUN = length, FUN.VALUE = integer(length = 1L)))
+}
+
+# Add missing cells to data added to /col_attrs
+#
+# @param x A list of vectors to add to /col_attrs
+# @param m2 The number of cells being added to the loom file
+#
+# @return 'x' with the proper number of cells
+#
+addCells.col_attrs <- function(x, m2) {
+  attrs.extend <- vapply(X = x, FUN = length, FUN.VALUE = integer(length = 1L))
+  attrs.extend <- which(x = attrs.extend != m2)
+  for (i in attrs.extend) {
+    attr <- x[[i]]
+    attr <- c(attr, rep.int(x = NA, times = m2 - length(x = attr)))
+    x[[i]] <- attr
+  }
+  return(x)
+}
+
+# Create a progress bar
+#
+# @return A progress bar
+#
+#' @importFrom utils txtProgressBar
+#
+new.pb <- function() {return(txtProgressBar(style = 3, char = '='))}
index 0c805bdaf2dfa4556b134bb430656e0fdb6fd777..7cb2b8ce6caec60f6e207f799ee0f3b1639abcdd 100644 (file)
--- a/R/loom.R
+++ b/R/loom.R
@@ -14,7 +14,7 @@ NULL
 #' @seealso \code{\link{hdf5r::H5File}}
 #'
 #' @field version Version of loomR object was created under
-#' @field shape Shape of \code{/matrix} in rows (genes) by cells (columns)
+#' @field shape Shape of \code{/matrix} in genes (columns) by cells (rows)
 #' @field chunksize Chunks set for this dataset in columns (cells) by rows (genes)
 #' @field matrix The main data matrix, stored as columns (cells) by rows (genes)
 #' @field layers Additional data matricies, the same shape as \code{/matrix}
@@ -56,6 +56,15 @@ NULL
 #'     Map a function onto a dataset within the loom file, returns the result into R.
 #'     The result will default to the shape of the dataset used; to change pass either 'vector' or 'matrix' to \code{expected}.
 #'   }
+#'   \item{\code{add.cells(matrix.data, attributes.data = NULL, layers.data = NULL, display.progress = TRUE)}}{
+#'     Add m2 cells to a loom file.
+#'     \describe{
+#'       \item{\code{matrix.data}}{a list of m2 cells where each entry is a vector of length n (num genes, \code{self$shape[1]})}
+#'       \item{\code{attributes.data}}{a list where each entry is named for one of the datasets in \code{self[['col_attrs']]}; each entry is a vector of length m2.}
+#'       \item{\code{layers.data}}{a list where each entry is named for one of the datasets in \cpde{self[['layers]]}; each entry is an n-by-m2 matrix where n is the number of genes in this loom file and m2 is the number of cells being added.}
+#'       \item{\code{display.progress}}{display progress}
+#'     }
+#'   }
 #' }
 #'
 #' @importFrom iterators nextElem
@@ -687,125 +696,86 @@ loom <- R6Class(
       return(results)
     },
     # Functions that modify `/matrix'
-    add.cells = function(matrix.data, attributes.data = NULL, layers.data = NULL) {
+    add.cells = function(
+      matrix.data,
+      attributes.data = NULL,
+      layers.data = NULL,
+      display.progress = TRUE
+    ) {
       if (self$mode == 'r') {
         stop("Cannot modify the loom file in read-only mode")
       }
-      # matrix.data is a vector of data for one cell or a list of data for several cells
-      # each entry in matrix.data must be the same length as number of genes
-      # attributes.data is an optional list or vector (with optional names) for col_attrs
-      # each entry in col_attrs must be the same length as the number of cells being added (NAs added for those that aren't)
-      # layers.data is an optional list (with optional names) for layers
-      # each entry in layers.data must be an N by M matrix where N is the number of genes and M is the number of cells
-      ##########################################################################
-      # Handle times when matrix.data exists as a vector of data for one cell
-      # Also handle matrix.data as matrix or dataframe
-      if ((is.vector(x = matrix.data) || is.factor(x = matrix.data)) && !is.list(x = matrix.data)) {
-        matrix.data <- list(matrix.data)
-      } else if (is.matrix(x = matrix.data) || is.data.frame(x = matrix.data)) {
-        matrix.data <- as.list(x = as.data.frame(x = matrix.data))
+      # Check inputs
+      n <- self[['matrix']]$dims[2]
+      if (display.progress) {
+        cat("Checking inputs...\n", file = stderr())
       }
-      # Check that all inputs are lists
-      list.check <- vapply(
-        X = list(matrix.data, attributes.data, layers.data),
-        FUN = function(x) {
-          return(is.list(x = x) || is.null(x = x))
-        },
-        FUN.VALUE = logical(length = 1L)
+      matrix.data <- check.matrix_data(x = matrix.data, n = n)
+      layers.data <- check.layers(
+        x = layers.data,
+        n = n,
+        layers.names = names(x = self[['layers']])
       )
-      if (!all(list.check)) {
-        stop("'matrix.data', 'attributes.data', and 'layers.data' must be lists")
-      }
-      # Check that all components of matrix.data contain the same number of genes the loom file
-      length.check <- vapply(
-        X = matrix.data,
-        FUN = function(x) {
-          return(length(x = x) == self$shape[2])
-        },
-        FUN.VALUE = logical(length = 1L)
+      attributes.data <- check.col_attrs(
+        x = attributes.data,
+        attrs.names = names(x = self[['col_attrs']])
       )
-      if (!all(length.check)) {
-        stop(paste(
-          "All values passed to matrix.data must have a length of",
-          self$shape[2]
-        ))
-      }
-      # Figure out the maximum number of cells we're adding
-      # matrix.data: one cell per entry, Mcells = length(x = matrix.data)
-      # attributes.data: one attribute per entry, multiple cells per entry:
-      #   Mcells = sapply(x = attributes.data, FUN = length)
-      # layers.data: one layer per entry, multiple cells per layer:
-      #   Mcells = sapply(X = layers.data, FUN = length) if each entry is not a matrix
-      #   Otherwise, Mcells = sapply(X = layers.data, FUN = ncol)
-      lengths <- vector(
-        mode = 'integer',
-        length = 1 + length(x = attributes.data) + length(x = layers.data)
+      # Get the number of cells we're adding
+      num.cells <- c(
+        nCells.matrix_data(x = matrix.data),
+        nCells.layers(x = layers.data),
+        nCells.col_attrs(x = attributes.data)
       )
-      # Find Mcells for matrix.data
-      lengths[1] <- length(x = matrix.data)
-      attributes.end <- 1 + length(x = attributes.data)
-      # Find Mcells for attributes.data
-      if (attributes.end != 1) {
-        lengths[2:attributes.end] <- vapply(
-          X = attributes.data,
-          FUN = length,
-          FUN.VALUE = integer(length = 1L)
-        )
+      num.cells <- max(num.cells)
+      # Flesh out the input data to add
+      if (display.progress) {
+        cat(paste("Adding", num.cells, "to this loom file\n"), file = stderr())
       }
-      if (attributes.end != length(x = lengths)) {
-        # Find Mcells for layers.data
-        lengths[(attributes.end + 1):length(x = lengths)] <- vapply(
-          X = layers.data,
-          FUN = function(x) {
-            # Mcells for matrix/data.frame entries
-            if (is.matrix(x = x) || is.data.frame(x = x)) {
-              check = nrow(x = x)
-              ret = ncol(x = x)
-            } else {
-              # Mcells for lists/vectors, cannot have a list of lists
-              check = length(x = x)
-              ret = 1L
-            }
-            # Check that each entry provides Ngenes entries
-            if (check != self$shape[2]) {
-              stop("Layer additions must have datapoints for all genes")
-            } else {
-              return(ret)
-            }
-          },
-          FUN.VALUE = integer(length = 1L)
-        )
+      matrix.data <- addCells.matrix_data(x = matrix.data, n = n, m2 = num.cells)
+      layers.data <- addCells.layers(x = layers.data, n = n, m2 = num.cells)
+      attributes.data <- addCells.col_attrs(x = attributes.data, m2 = num.cells)
+      # Add the input to the loom file
+      dims.fill <- self[['matrix']]$dims[1]
+      dims.fill <- (dims.fill + 1L):(dims.fill + num.cells)
+      # Matrix data
+      if (display.progress) {
+        cat("Adding data to /matrix\n", file = stderr())
       }
-      # Get the maximum number of cells we're adding
-      num.cells.added <- max(lengths)
-      # Fill out everything else with NAs
-      # matrix.data <- c(
-      #   matrix.data,
-      #   rep.int(
-      #     x = list(rep.int(x = NA, times = self$shape[2])),
-      #     times = num.cells.added - length(x = self$shape[2])
-      #   )
-      # )
-      datasets.check <- c(
-        'matrix',
-        grep(pattern = 'layers', x = list.datasets(object = self), value = TRUE)
-      )
-      max.check <- vapply(
-        X = datasets.check,
-        FUN = function(dset, ncells) {
-          return((self[[dset]]$dims[1] + ncells) > self[[dset]]$maxdims[1])
-        },
-        FUN.VALUE = logical(length = 1L),
-        ncells = num.cells.added
-      )
-      if (any(max.check)) {
-        stop()
+      matrix.data <- t(x = as.matrix(x = data.frame(matrix.data)))
+      self[['matrix']][dims.fill, ] <- matrix.data
+      # Layer data
+      if (display.progress) {
+        cat("Adding data to /layers\n", file = stderr())
+        pb <- new.pb()
+        counter <- 0
+      }
+      layers.names <- names(x = self[['layers']])
+      for (i in layers.names) {
+        self[['layers', i]][dims.fill, ] <- t(x = layers.data[[i]])
+        if (display.progress) {
+          counter <- counter + 1
+          setTxtProgressBar(pb = pb, value = counter / length(x = layers.names))
+        }
+      }
+      # Column attributes
+      if (display.progress) {
+        cat("Adding data to /col_attrs\n", file = stderr())
+        pb <- new.pb()
+        counter <- 0
+      }
+      attrs.names <- names(x = self[['col_attrs']])
+      for (i in attrs.names) {
+        self[['col_attrs', i]][dims.fill] <- attributes.data[[i]]
+        if (display.progress) {
+          counter <- counter + 1
+          setTxtProgressBar(pb = pb, value = counter / length(x = attrs.names))
+        }
       }
       # # Load layers and attributes
       # private$load_layers()
       # private$load_attributes(MARGIN = 1)
       # private$load_attributes(MARGIN = 2)
-      self$shape <- self[['matrix']]$dims
+      self$shape <- self[['matrix']]$dims
     }
     # add.loom = function() {}
   ),
@@ -1028,7 +998,7 @@ connect <- function(filename, mode = "r", skip.validate = FALSE) {
 #'
 #' @return A loom object connected to \code{filename}
 #'
-#' @importFrom utils txtProgressBar setTxtProgressBar
+#' @importFrom utils setTxtProgressBar
 #'
 #' @export subset.loom
 #' @method subset loom
@@ -1042,7 +1012,6 @@ subset.loom <- function(
   display.progress = TRUE,
   ...
 ) {
-  new.pb <- function() {return(txtProgressBar(style = 3, char = '='))}
   # Set some defaults
   if (is.null(x = m)) {
     m <- 1:x$shape[1]
@@ -1052,7 +1021,7 @@ subset.loom <- function(
   }
   if (is.null(x = filename)) {
     filename <- paste(
-      unlist(x = strsplit(x = lfile$filename, split = '.', fixed = TRUE)),
+      unlist(x = strsplit(x = x$filename, split = '.', fixed = TRUE)),
       collapse = '_subset.'
     )
   }
index dfa234520aa91feb5d8eda495681fa5d55206ce5..9828ec9444ae026daaaedfaf6eeabb38989b4387 100644 (file)
@@ -20,7 +20,7 @@ A class for loom files
 \describe{
 \item{\code{version}}{Version of loomR object was created under}
 
-\item{\code{shape}}{Shape of \code{/matrix} in rows (genes) by cells (columns)}
+\item{\code{shape}}{Shape of \code{/matrix} in genes (columns) by cells (rows)}
 
 \item{\code{chunksize}}{Chunks set for this dataset in columns (cells) by rows (genes)}
 
@@ -69,6 +69,15 @@ A class for loom files
     Map a function onto a dataset within the loom file, returns the result into R.
     The result will default to the shape of the dataset used; to change pass either 'vector' or 'matrix' to \code{expected}.
   }
+  \item{\code{add.cells(matrix.data, attributes.data = NULL, layers.data = NULL, display.progress = TRUE)}}{
+    Add m2 cells to a loom file.
+    \describe{
+      \item{\code{matrix.data}}{a list of m2 cells where each entry is a vector of length n (num genes, \code{self$shape[1]})}
+      \item{\code{attributes.data}}{a list where each entry is named for one of the datasets in \code{self[['col_attrs']]}; each entry is a vector of length m2.}
+      \item{\code{layers.data}}{a list where each entry is named for one of the datasets in \cpde{self[['layers]]}; each entry is an n-by-m2 matrix where n is the number of genes in this loom file and m2 is the number of cells being added.}
+      \item{\code{display.progress}}{display progress}
+    }
+  }
 }
 }