Remove redundant code
[loomr.git] / R / internal.R
1 # Generate chunk points
2 #
3 # @param data.size How big is the data being chunked
4 # @param chunk.size How big should each chunk be
5 #
6 # @return A matrix where each column is a chunk, row 1 is start points, row 2 is end points
7 #
8 chunkPoints <- function(data.size, chunk.size) {
9   return(vapply(
10     X = 1L:ceiling(data.size / chunk.size),
11     FUN = function(i) {
12       return(c(
13         start = (chunk.size * (i - 1L)) + 1L,
14         end = min(chunk.size * i, data.size)
15       ))
16     },
17     FUN.VALUE = numeric(length = 2L)
18   ))
19 }
20
21 # Get HDF5 data types
22 #
23 # @param x An R object or string describing HDF5 datatype
24 #
25 # @return The corresponding HDF5 data type
26 #
27 # @ rdname getDtype
28 #
29 #' @import hdf5r
30 #
31 # @seealso \code\link{hdf5r::h5types}
32 #
33 getDtype <- function(x) {
34   return(switch(
35     EXPR = class(x = x),
36     'numeric' = h5types$double,
37     'integer' = h5types$int,
38     'character' = H5T_STRING$new(size = Inf),
39     'logical' = H5T_LOGICAL$new(),
40     stop(paste("Unknown data type:", class(x = x)))
41   ))
42 }
43
44 # @describeIn getDtype A version of getDtype that works specifically for hdf5r types,
45 # useful for getDtype2(x = class(x = object[['dataset']]$get_type())[1])
46 #
47 getDtype2 <- function(x) {
48   return(getDtype(x = switch(
49     EXPR = x,
50     'H5T_FLOAT' = numeric(),
51     'H5T_INTEGER' = integer(),
52     'H5T_STRING' = character(),
53     'H5T_LOGICAL' = logical(),
54     stop(paste("Unkown data type:", x))
55   )))
56 }
57
58 # Validate a loom object
59 #
60 # @param object A loom object
61 #
62 # @return None, errors out if object is an invalid loom connection
63 #
64 # @seealso \code{\link{loom-class}}
65 #
66 validateLoom <- function(object) {
67   if (!inherits(x = object, what = 'loom')) {
68     stop("No need to validate a non-loom object")
69   }
70   # A loom file is a specific HDF5
71   # We need a dataset in /matrix that's a two-dimensional dense matrix
72   root.datasets <- list.datasets(object = object, path = '/', recursive = FALSE)
73   if (length(x = root.datasets) != 1) {
74     stop("There can only be one dataset at the root of the loom file")
75   }
76   if (root.datasets != 'matrix') {
77     stop("The root dataset must be called '/matrix'")
78   }
79   # There must be groups called '/col_attrs', '/row_attrs', and '/layers'
80   required.groups <- c('row_attrs', 'col_attrs', 'layers', 'row_edges', 'col_edges')
81   dim.matrix <- object[['matrix']]$dims # Columns x Rows
82   names(x = dim.matrix) <- required.groups[c(2, 1)]
83   root.groups <- list.groups(object = object, path = '/', recursive = FALSE)
84   group.msg <- paste0(
85     paste("There can only be", length(x = required.groups), "groups in the loom file: '"),
86     paste(required.groups, collapse = "', '"),
87     "'"
88   )
89   reopen.msg <- paste(
90     group.msg,
91     "Reopen in 'r+' mode to automatically add missing groups",
92     sep = '\n'
93   )
94   if (length(x = root.groups) > length(x = required.groups)) {
95     stop(group.msg)
96   } else if (length(x = root.groups) < length(x = required.groups)) {
97     if (all(root.groups %in% required.groups)) {
98       if (object$mode != 'r') {
99         missing.groups <- required.groups[!(required.groups %in% root.groups)]
100         for (group in missing.groups) {
101           object$create_group(name = group)
102         }
103         root.groups <- list.groups(object = object, path = '/', recursive = FALSE)
104       } else {
105         object$close_all()
106         stop(reopen.msg)
107       }
108     } else {
109       stop(group.msg)
110     }
111   }
112   if (!all(required.groups %in% root.groups)) {
113     stop(group.msg)
114   }
115   # Check row and column attributes
116   for (group in required.groups[1:2]) {
117     # No subgroups
118     if (length(x = list.groups(object = object[[group]], recursive = FALSE)) > 0) {
119       stop(paste("Group", group, "cannot have subgroups"))
120     }
121     # All datasets must have their first (last) dimmension equal to M(row) or N(column)
122     for (dataset in list.datasets(object = object[[group]])) {
123       dataset.dim <- object[[group]][[dataset]]$dims
124       dataset.dim <- dataset.dim[length(x = dataset.dim)]
125       if (dataset.dim != dim.matrix[group]) {
126         print(dataset)
127         print(object[[group]][[dataset]])
128         print(dim.matrix)
129         stop("All datasets in group ", group, " must be of length ", dim.matrix[group])
130       }
131     }
132   }
133   # Check layers
134   for (dataset in list.datasets(object = object[['/layers']])) {
135     if (any(object[[paste('layers', dataset, sep = '/')]]$dims != dim.matrix)) {
136       stop(paste("All datasets in '/layers' must be", dim.matrix[1], 'by', dim.matrix[2]))
137     }
138   }
139 }
140
141 # A function to determine if a vector is a vector and not a list
142 #
143 # @param x An object
144 #
145 # @return TRUE if 'x' is a vector or a factor, otherwise FALSE
146 #
147 is.actual_vector <- function(x) {
148   return((is.vector(x = x) || is.factor(x = x)) && !is.list(x = x))
149 }
150
151 # Check additions to /matrix
152 #
153 # @param x A list of vectors to add to /matrix
154 # @param n The number of genes needed in each cell
155 #
156 # @return 'x' as a list of vectors
157 #
158 check.matrix_data <- function(x, n) {
159   # Coerce x into a list, where each
160   # entry in the list is a new cell added
161   if (is.actual_vector(x = x)) {
162     x <- list(x)
163   } else if (is.matrix(x = x) || is.data.frame(x = x)) {
164     x <- as.list(x = x)
165   }
166   if (!is.list(x = x)) {
167     stop("Matrix data must be a list of vectors")
168   }
169   # Ensure that each entry in the list is a vector of length n
170   vector.check <- vapply(
171     X = x,
172     FUN = is.actual_vector,
173     FUN.VALUE = logical(length = 1L)
174   )
175   if (!all(vector.check)) {
176     stop('Each new cell added must be represented as a vector')
177   }
178   # Ensure each new cell added has data for the number of genes present
179   for (i in 1:length(x = x)) {
180     cell.add <- x[[i]]
181     if (length(x = cell.add) > n) {
182       stop(paste(
183         "Cannot add genes to a loom file, the maximum number of genes allowed is",
184         n
185       ))
186     } else if (length(x = cell.add) < n) {
187       cell.add[(length(x = cell.add) + 1):n] <- NA
188     }
189     x[[i]] <- cell.add
190   }
191   return(x)
192 }
193
194 # Get the number of cells being added to /matrix
195 #
196 # @param x A list of vectors to add to /matrix
197 #
198 # @return The number of cells in x
199 #
200 nCells.matrix_data <- function(x) {
201   return(length(x = x))
202 }
203
204 # Add missing cells to data added to /matrix
205 #
206 # @param x A list of vectors to add to /matrix
207 # @param n The number of genes each cell needs
208 # @param m2 The number of cells being added to the loom file
209 #
210 # @return 'x' with the proper number of cells
211 #
212 addCells.matrix_data <- function(x, n, m2) {
213   if (length(x = x) < m2) {
214     x[(length(x = x) + 1):m2] <- list(rep.int(x = NA, times = n))
215   }
216   return(x)
217 }
218
219 # Check additions to /layers
220 #
221 # @param x A list of matrices to add layers in /layers
222 # @param n The number of genes needed for each layer
223 # @param layers.names Names found in /layers
224 #
225 # @return 'x' as a list of matricies with 'n' rows for each layer present in /layers
226 #
227 check.layers <- function(x, n, layers.names) {
228   # Coerce x into a list of matricies
229   if (is.null(x = x)) {
230     x <- list()
231   } else if (is.matrix(x = x) || is.data.frame(x = x)) {
232     x <- list(as.matrix(x = x))
233   }
234   if (!is.list(x = x)) {
235     stop("Layers data must be a list of matricies")
236   }
237   # Ensure we have enough layer additions for each layer
238   # Manage named lists, taking only those with the same name as in /layers
239   # or is named with an empty string
240   if (!is.null(x = names(x = x))) {
241     x.use <- which(x = names(x = x) %in% layers.names | names(x = x) == '')
242     x <- x[x.use]
243   }
244   if (length(x = x) > length(x = layers.names)) {
245     stop("Cannot add more layers than already present")
246   } else if (length(x = x) < length(x = layers.names)) {
247     x[(length(x = x) + 1):length(x = layers.names)] <- data.frame(rep.int(x = NA, times = n))
248   }
249   # Ensure that we have all genes needed
250   for (i in 1:length(x = x)) {
251     layer <- x[[i]]
252     if (is.data.frame(x = layer)) {
253       layer <- as.matrix(x = layer)
254     } else if (is.actual_vector(x = layer)) {
255       layer <- matrix(data = layer, ncol = 1)
256     }
257     if (!is.matrix(x = layer)) {
258       stop("Layers data must be a list of matrices")
259     }
260     if (nrow(x = layer) > n) {
261       stop(paste(
262         "Cannot add genes to a loom file, the maximum number of genes allowed is",
263         n
264       ))
265     } else if (nrow(x = layer) < n) {
266       layer <- as.data.frame(x = layer)
267       layer[(nrow(x = layer) + 1):n, ] <- NA
268       layer <- as.matrix(x = layer)
269     }
270     x[[i]] <- layer
271   }
272   # Set names
273   x.unnamed <- which(x = !(names(x = x) %in% layers.names))
274   if (length(x = x.unnamed) == 0) {
275     x.unnamed <- 1:length(x = x)
276   }
277   names.unused <- which(x = !(layers.names %in% names(x = x)))
278   names(x = x)[x.unnamed] <- layers.names[names.unused]
279   return(x)
280 }
281
282 # Get the number of cells being added to /layers
283 #
284 # @param x A list of matricies to add to /layers
285 #
286 # @return The number of cells within each matrix
287 #
288 nCells.layers <- function(x) {
289   return(vapply(X = x, FUN = ncol, FUN.VALUE = integer(length = 1L)))
290 }
291
292 # Add missing cells to data added to /matrix
293 #
294 # @param x A list of matricies to add to /layers
295 # @param n The number of genes each cell needs
296 # @param m2 The number of cells being added to the loom file
297 #
298 # @return 'x' with the proper number of cells
299 #
300 addCells.layers <- function(x, n, m2) {
301   layers.extend <- vapply(X = x, FUN = ncol, FUN.VALUE = integer(length = 1L))
302   layers.extend <- which(x = layers.extend != m2)
303   for (i in layers.extend) {
304     layer <- x[[i]]
305     layer.new <- matrix(nrow = n, ncol = m2)
306     layer.new[, 1:ncol(x = layer)] <- layer
307     x[[i]] <- layer.new
308     gc(verbose = FALSE)
309   }
310   return(x)
311 }
312
313 # Check additions to /col_attrs
314 #
315 # @param x A list of vectors to add to /col_attrs
316 # @param attrs.names Names of attributes found in /col_attrs
317 #
318 # @return 'x' as a list of vectors for each attribute found in /col_attrs
319 #
320 check.col_attrs <- function(x, attrs.names) {
321   # Coerce x into a list of vectors
322   if (is.null(x = x)) {
323     x <- list()
324   } else if (is.actual_vector(x = x)) {
325     x <- list(x)
326   } else if (is.matrix(x = x) || is.data.frame(x = x)) {
327     x <- as.list(x = x)
328   }
329   if (!is.list(x = x)) {
330     stop("Attribute data must be a list of vectors")
331   }
332   # Ensure we have enough attribute additions for each col_attr
333   # Manage named lists, taking only those with the same name as in /col_attrs
334   # or is named with an empty string
335   if (!is.null(x = names(x = x))) {
336     x.use <- which(x = names(x = x) %in% attrs.names | names(x = x) == '')
337     x <- x[x.use]
338   }
339   if (length(x = x) > length(x = attrs.names)) {
340     stop("Cannot add more column attributes than already present")
341   } else if (length(x = x) < length(x = attrs.names)) {
342     x[(length(x = x) + 1):length(x = attrs.names)] <- NA
343   }
344   if (!all(vapply(X = x, FUN = is.actual_vector, FUN.VALUE = logical(length = 1L)))) {
345     stop("Attribute data must be a list of vectors")
346   }
347   # Set names
348   x.unnamed <- which(x = !(names(x = x) %in% attrs.names))
349   if (length(x = x.unnamed) == 0) {
350     x.unnamed <- 1:length(x = x)
351   }
352   names.unused <- which(x = !(attrs.names %in% names(x = x)))
353   names(x = x)[x.unnamed] <- attrs.names[names.unused]
354   return(x)
355 }
356
357 # Get the number of cells being added to /col_attrs
358 #
359 # @param x A list of vectors to add to /col_attrs
360 #
361 # @return The number of cells for each attribute
362 #
363 nCells.col_attrs <- function(x) {
364   return(vapply(X = x, FUN = length, FUN.VALUE = integer(length = 1L)))
365 }
366
367 # Add missing cells to data added to /col_attrs
368 #
369 # @param x A list of vectors to add to /col_attrs
370 # @param m2 The number of cells being added to the loom file
371 #
372 # @return 'x' with the proper number of cells
373 #
374 addCells.col_attrs <- function(x, m2) {
375   attrs.extend <- vapply(X = x, FUN = length, FUN.VALUE = integer(length = 1L))
376   attrs.extend <- which(x = attrs.extend != m2)
377   for (i in attrs.extend) {
378     attr <- x[[i]]
379     attr <- c(attr, rep.int(x = NA, times = m2 - length(x = attr)))
380     x[[i]] <- attr
381   }
382   return(x)
383 }
384
385 # Create a progress bar
386 #
387 # @return A progress bar
388 #
389 #' @importFrom utils txtProgressBar
390 #
391 new.pb <- function() {
392   return(txtProgressBar(style = 3, char = '='))
393 }
394
395 # Cat with a new line
396 #
397 # @param ... Text to be output
398 #
399 catn <- function(...) {
400   x = list(...)
401   if (length(x = x)) {
402     if (!is.null(x = names(x = x)) && length(x = x) == 1 && names(x = x) == 'file') {
403       cat(...)
404     } else {
405       cat(..., '\n')
406     }
407   } else {
408     cat()
409   }
410 }
411
412 # Cat to stderr
413 #
414 # @param ... Text to be output
415 #
416 cate <- function(...) {
417   catn(..., file = stderr())
418 }