Add validation for graphs
[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_graphs', 'col_graphs')
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 (any(grepl(pattern = 'edges', x = root.groups))) {
95     if (object$mode != 'r') {
96       cate("Moving edge groups to graph groups to conform to loom v2.0.1")
97       edges <- grep(pattern = 'edges', x = root.groups, value = TRUE)
98       for (group in edges) {
99         graph <- gsub(pattern = 'edges', replacement = 'graphs', x = group)
100         object$link_move_to(dst_loc = object, dst_name = graph, src_name = group)
101       }
102       root.groups <- list.groups(object = object, path = '/', recursive = FALSE)
103     } else {
104       object$close_all()
105       stop(reopen.msg)
106     }
107   }
108   if (length(x = root.groups) > length(x = required.groups)) {
109     stop(group.msg)
110   } else if (length(x = root.groups) < length(x = required.groups)) {
111     if (all(root.groups %in% required.groups)) {
112       if (object$mode != 'r') {
113         missing.groups <- required.groups[!(required.groups %in% root.groups)]
114         for (group in missing.groups) {
115           object$create_group(name = group)
116         }
117         root.groups <- list.groups(object = object, path = '/', recursive = FALSE)
118       } else {
119         object$close_all()
120         stop(reopen.msg)
121       }
122     } else {
123       stop(group.msg)
124     }
125   }
126   if (!all(required.groups %in% root.groups)) {
127     stop(group.msg)
128   }
129   # Check row and column attributes
130   for (group in required.groups[1:2]) {
131     # No subgroups
132     if (length(x = list.groups(object = object[[group]], recursive = FALSE)) > 0) {
133       stop(paste("Group", group, "cannot have subgroups"))
134     }
135     # All datasets must have their first (last) dimmension equal to M(row) or N(column)
136     for (dataset in list.datasets(object = object[[group]])) {
137       dataset.dim <- object[[group]][[dataset]]$dims
138       dataset.dim <- dataset.dim[length(x = dataset.dim)]
139       if (dataset.dim != dim.matrix[group]) {
140         print(dataset)
141         print(object[[group]][[dataset]])
142         print(dim.matrix)
143         stop("All datasets in group ", group, " must be of length ", dim.matrix[group])
144       }
145     }
146   }
147   # Check row and column graphs
148   graph.groups <- grep(pattern = 'graphs', x = required.groups, value = TRUE)
149   graph.msg <- "There can only be three datasets in a graph: 'a', 'b', and 'w'"
150   for (group in graph.groups) {
151     group.datasets <- list.datasets(object = object[[group]], recursive = FALSE)
152     if (length(x = group.datasets) > 0) {
153       stop(paste("All datasets in", group, "must be in a graph group"))
154     }
155     graphs <- list.groups(object = object[[group]], full.names = TRUE, recursive = FALSE)
156     for (graph in graphs) {
157       graph.datasets <- list.datasets(object = object[[graph]], full.names = TRUE)
158       if (length(x = graph.datasets) != 3) {
159         stop(graph.msg)
160       }
161       if (!all(basename(path = graph.datasets) %in% c('a', 'b', 'w'))) {
162         stop(graph.msg)
163       }
164       graph.lengths <- lapply(
165         X = graph.datasets,
166         FUN = function(dset) {
167           return(object[[dset]]$dims)
168         }
169       )
170       if (unique(x = length(x = graph.lengths)) != 1) {
171         stop("All graph datasets must be the same length")
172       }
173     }
174   }
175   # Check layers
176   for (dataset in list.datasets(object = object[['/layers']])) {
177     if (any(object[[paste('layers', dataset, sep = '/')]]$dims != dim.matrix)) {
178       stop(paste("All datasets in '/layers' must be", dim.matrix[1], 'by', dim.matrix[2]))
179     }
180   }
181 }
182
183 # A function to determine if a vector is a vector and not a list
184 #
185 # @param x An object
186 #
187 # @return TRUE if 'x' is a vector or a factor, otherwise FALSE
188 #
189 is.actual_vector <- function(x) {
190   return((is.vector(x = x) || is.factor(x = x)) && !is.list(x = x))
191 }
192
193 # Check additions to /matrix
194 #
195 # @param x A list of vectors to add to /matrix
196 # @param n The number of genes needed in each cell
197 #
198 # @return 'x' as a list of vectors
199 #
200 check.matrix_data <- function(x, n) {
201   # Coerce x into a list, where each
202   # entry in the list is a new cell added
203   if (is.actual_vector(x = x)) {
204     x <- list(x)
205   } else if (is.matrix(x = x) || is.data.frame(x = x)) {
206     x <- as.list(x = x)
207   }
208   if (!is.list(x = x)) {
209     stop("Matrix data must be a list of vectors")
210   }
211   # Ensure that each entry in the list is a vector of length n
212   vector.check <- vapply(
213     X = x,
214     FUN = is.actual_vector,
215     FUN.VALUE = logical(length = 1L)
216   )
217   if (!all(vector.check)) {
218     stop('Each new cell added must be represented as a vector')
219   }
220   # Ensure each new cell added has data for the number of genes present
221   for (i in 1:length(x = x)) {
222     cell.add <- x[[i]]
223     if (length(x = cell.add) > n) {
224       stop(paste(
225         "Cannot add genes to a loom file, the maximum number of genes allowed is",
226         n
227       ))
228     } else if (length(x = cell.add) < n) {
229       cell.add[(length(x = cell.add) + 1):n] <- NA
230     }
231     x[[i]] <- cell.add
232   }
233   return(x)
234 }
235
236 # Get the number of cells being added to /matrix
237 #
238 # @param x A list of vectors to add to /matrix
239 #
240 # @return The number of cells in x
241 #
242 nCells.matrix_data <- function(x) {
243   return(length(x = x))
244 }
245
246 # Add missing cells to data added to /matrix
247 #
248 # @param x A list of vectors to add to /matrix
249 # @param n The number of genes each cell needs
250 # @param m2 The number of cells being added to the loom file
251 #
252 # @return 'x' with the proper number of cells
253 #
254 addCells.matrix_data <- function(x, n, m2) {
255   if (length(x = x) < m2) {
256     x[(length(x = x) + 1):m2] <- list(rep.int(x = NA, times = n))
257   }
258   return(x)
259 }
260
261 # Check additions to /layers
262 #
263 # @param x A list of matrices to add layers in /layers
264 # @param n The number of genes needed for each layer
265 # @param layers.names Names found in /layers
266 #
267 # @return 'x' as a list of matricies with 'n' rows for each layer present in /layers
268 #
269 check.layers <- function(x, n, layers.names) {
270   # Coerce x into a list of matricies
271   if (is.null(x = x)) {
272     x <- list()
273   } else if (is.matrix(x = x) || is.data.frame(x = x)) {
274     x <- list(as.matrix(x = x))
275   }
276   if (!is.list(x = x)) {
277     stop("Layers data must be a list of matricies")
278   }
279   # Ensure we have enough layer additions for each layer
280   # Manage named lists, taking only those with the same name as in /layers
281   # or is named with an empty string
282   if (!is.null(x = names(x = x))) {
283     x.use <- which(x = names(x = x) %in% layers.names | names(x = x) == '')
284     x <- x[x.use]
285   }
286   if (length(x = x) > length(x = layers.names)) {
287     stop("Cannot add more layers than already present")
288   } else if (length(x = x) < length(x = layers.names)) {
289     x[(length(x = x) + 1):length(x = layers.names)] <- data.frame(rep.int(x = NA, times = n))
290   }
291   # Ensure that we have all genes needed
292   for (i in 1:length(x = x)) {
293     layer <- x[[i]]
294     if (is.data.frame(x = layer)) {
295       layer <- as.matrix(x = layer)
296     } else if (is.actual_vector(x = layer)) {
297       layer <- matrix(data = layer, ncol = 1)
298     }
299     if (!is.matrix(x = layer)) {
300       stop("Layers data must be a list of matrices")
301     }
302     if (nrow(x = layer) > n) {
303       stop(paste(
304         "Cannot add genes to a loom file, the maximum number of genes allowed is",
305         n
306       ))
307     } else if (nrow(x = layer) < n) {
308       layer <- as.data.frame(x = layer)
309       layer[(nrow(x = layer) + 1):n, ] <- NA
310       layer <- as.matrix(x = layer)
311     }
312     x[[i]] <- layer
313   }
314   # Set names
315   x.unnamed <- which(x = !(names(x = x) %in% layers.names))
316   if (length(x = x.unnamed) == 0) {
317     x.unnamed <- 1:length(x = x)
318   }
319   names.unused <- which(x = !(layers.names %in% names(x = x)))
320   names(x = x)[x.unnamed] <- layers.names[names.unused]
321   return(x)
322 }
323
324 # Get the number of cells being added to /layers
325 #
326 # @param x A list of matricies to add to /layers
327 #
328 # @return The number of cells within each matrix
329 #
330 nCells.layers <- function(x) {
331   return(vapply(X = x, FUN = ncol, FUN.VALUE = integer(length = 1L)))
332 }
333
334 # Add missing cells to data added to /matrix
335 #
336 # @param x A list of matricies to add to /layers
337 # @param n The number of genes each cell needs
338 # @param m2 The number of cells being added to the loom file
339 #
340 # @return 'x' with the proper number of cells
341 #
342 addCells.layers <- function(x, n, m2) {
343   layers.extend <- vapply(X = x, FUN = ncol, FUN.VALUE = integer(length = 1L))
344   layers.extend <- which(x = layers.extend != m2)
345   for (i in layers.extend) {
346     layer <- x[[i]]
347     layer.new <- matrix(nrow = n, ncol = m2)
348     layer.new[, 1:ncol(x = layer)] <- layer
349     x[[i]] <- layer.new
350     gc(verbose = FALSE)
351   }
352   return(x)
353 }
354
355 # Check additions to /col_attrs
356 #
357 # @param x A list of vectors to add to /col_attrs
358 # @param attrs.names Names of attributes found in /col_attrs
359 #
360 # @return 'x' as a list of vectors for each attribute found in /col_attrs
361 #
362 check.col_attrs <- function(x, attrs.names) {
363   # Coerce x into a list of vectors
364   if (is.null(x = x)) {
365     x <- list()
366   } else if (is.actual_vector(x = x)) {
367     x <- list(x)
368   } else if (is.matrix(x = x) || is.data.frame(x = x)) {
369     x <- as.list(x = x)
370   }
371   if (!is.list(x = x)) {
372     stop("Attribute data must be a list of vectors")
373   }
374   # Ensure we have enough attribute additions for each col_attr
375   # Manage named lists, taking only those with the same name as in /col_attrs
376   # or is named with an empty string
377   if (!is.null(x = names(x = x))) {
378     x.use <- which(x = names(x = x) %in% attrs.names | names(x = x) == '')
379     x <- x[x.use]
380   }
381   if (length(x = x) > length(x = attrs.names)) {
382     stop("Cannot add more column attributes than already present")
383   } else if (length(x = x) < length(x = attrs.names)) {
384     x[(length(x = x) + 1):length(x = attrs.names)] <- NA
385   }
386   if (!all(vapply(X = x, FUN = is.actual_vector, FUN.VALUE = logical(length = 1L)))) {
387     stop("Attribute data must be a list of vectors")
388   }
389   # Set names
390   x.unnamed <- which(x = !(names(x = x) %in% attrs.names))
391   if (length(x = x.unnamed) == 0) {
392     x.unnamed <- 1:length(x = x)
393   }
394   names.unused <- which(x = !(attrs.names %in% names(x = x)))
395   names(x = x)[x.unnamed] <- attrs.names[names.unused]
396   return(x)
397 }
398
399 # Get the number of cells being added to /col_attrs
400 #
401 # @param x A list of vectors to add to /col_attrs
402 #
403 # @return The number of cells for each attribute
404 #
405 nCells.col_attrs <- function(x) {
406   return(vapply(X = x, FUN = length, FUN.VALUE = integer(length = 1L)))
407 }
408
409 # Add missing cells to data added to /col_attrs
410 #
411 # @param x A list of vectors to add to /col_attrs
412 # @param m2 The number of cells being added to the loom file
413 #
414 # @return 'x' with the proper number of cells
415 #
416 addCells.col_attrs <- function(x, m2) {
417   attrs.extend <- vapply(X = x, FUN = length, FUN.VALUE = integer(length = 1L))
418   attrs.extend <- which(x = attrs.extend != m2)
419   for (i in attrs.extend) {
420     attr <- x[[i]]
421     attr <- c(attr, rep.int(x = NA, times = m2 - length(x = attr)))
422     x[[i]] <- attr
423   }
424   return(x)
425 }
426
427 # Create a progress bar
428 #
429 # @return A progress bar
430 #
431 #' @importFrom utils txtProgressBar
432 #
433 new.pb <- function() {
434   return(txtProgressBar(style = 3, char = '='))
435 }
436
437 # Cat with a new line
438 #
439 # @param ... Text to be output
440 #
441 catn <- function(...) {
442   x = list(...)
443   if (length(x = x)) {
444     if (!is.null(x = names(x = x)) && length(x = x) == 1 && names(x = x) == 'file') {
445       cat(...)
446     } else {
447       cat(..., '\n')
448     }
449   } else {
450     cat()
451   }
452 }
453
454 # Cat to stderr
455 #
456 # @param ... Text to be output
457 #
458 cate <- function(...) {
459   catn(..., file = stderr())
460 }