Updates to the initialize method and add functionality to other methods
[loomr.git] / R / loom.R
1 #' @import hdf5r
2 #' @importFrom R6 R6Class
3 NULL
4
5 #' A class for loom
6 #'
7 #' @docType class
8 #' @name loom-class
9 #' @rdname loom-class
10 #' @return Object of class \code{\link{loom}}
11 #' @seealso \code{\link{hdf5r::H5File}}
12 #'
13 #' @importFrom utils packageVersion
14 #'
15 #' @export
16 #'
17 loom <- R6Class(
18   classname = 'loom',
19   inherit = hdf5r::H5File,
20   cloneable = FALSE,
21   portable = TRUE,
22   lock_class = TRUE,
23   public = list(
24     # Fields
25     version = NULL,
26     shape = NULL,
27     chunksize = NULL,
28     matrix = NULL,
29     layers = NULL,
30     col.attrs = NULL,
31     row.attrs = NULL,
32     # Methods
33     initialize = function(filename = NULL, mode = c('a', 'r', 'r+', 'w', 'w-'), ...) {
34       # If the file exists, run validation steps
35       do.validate <- file.exists(filename) && !(mode %in% c('w', 'w+'))
36       super$initialize(filename = filename, mode = mode, ...)
37       if (do.validate) {
38         # Run the validation steps
39         validateLoom(object = self)
40         # Store the shape of /matrix
41         self$shape <- rev(x = self[['matrix']]$dims)
42         # Store the chunk size
43         chunks <- h5attr(x = self, which = 'chunks')
44         chunks <- gsub(pattern = '(', replacement = '', x = chunks, fixed = TRUE)
45         chunks <- gsub(pattern = ')', replacement = '', x = chunks, fixed = TRUE)
46         chunks <- unlist(x = strsplit(x = chunks, split = ','))
47         self$chunks <- rev(x = as.integer(x = chunks))
48         # Store version information
49         self$version <- as.character(x = tryCatch(
50           # Try getting a version
51           # If it doesn't exist, can we write to the file?
52           # If so, store the version as this version of loomR
53           # Otherwise, store the version as NA_character_
54           expr = h5attr(x = self, which = 'version'),
55           error = function(e) {
56             if (mode != 'r') {
57               version <- packageVersion(pkg = 'loomR')
58               h5attr(x = self, which = 'version') <- version
59             } else {
60               version <- NA_character_
61             }
62             return(version)
63           }
64         ))
65         # Load layers
66         private$load_layers()
67         # Load attributes
68         private$load_attirubtes(MARGIN = 1)
69         private$load_attributes(MARGIN = 2)
70       } else {
71         # Assume new HDF5 file
72         self$version <- packageVersion(pkg = 'loomR')
73       }
74     },
75     add.layer = function(layer, name) {
76       if (!is.matrix(x = layer)) {
77         layer <- as.matrix(x = layer)
78       }
79       if (is.null(x = self$shape)) {
80         stop(private$err_msg)
81       }
82       if (dim(x = layer) != self$shape) {
83         stop(
84           paste(
85             "All layers must have a shape of",
86             paste(self$shape, collapse = ' by ')
87           )
88         )
89       }
90       self[['layers', name]] <- t(x = layer)
91       private$load_layers()
92     },
93     add.attribute = function(attribute, MARGIN) {
94       # Value checking
95       if (!is.list(x = attribute) || is.null(x = names(x = attribute))) {
96         stop("'attribute' must be a named list")
97       }
98       if (length(x = attribute) > 1) {
99         for (i in attribute) {
100           if (!is.vector(x = attribute)) {
101             stop("All attributes must be one-dimensional vectors")
102           }
103         }
104       }
105       if (length(x = which(x = names(x = attribute) != '')) != length(x = attribute)) {
106         stop("Not all attributes had names provided")
107       }
108       if (!MARGIN %in% c(1, 2)) {
109         stop("'MARGIN' must be 1 or 2")
110       }
111       # Add the attributes as datasets for our MARGIN's group
112       if (is.null(x = self$shape)) {
113         stop(private$err_msg)
114       }
115       grp.name <- c('row_attrs', 'col_attrs')[MARGIN]
116       grp <- self[[grp.name]]
117       for (i in 1:length(x = attribute)) {
118         if (length(attribute[i]) != self$shape[MARGIN])
119           stop(paste(
120             "All",
121             switch(EXPR = MARGIN, '1' = 'row', '2' = 'column'),
122             "attributes must be of length",
123             self$shape[MARGIN]
124           ))
125         grp[[names(x = attribute)[i]]] <- attribute[[i]]
126       }
127       gc(verbose = FALSE)
128       # Load the attributes for this margin
129       private$load_attributes(MARGIN = MARGIN)
130     },
131     add.row.attribute = function(attribute) {
132       self$add.attribute(attribute = attribute, MARGIN = 1)
133     },
134     add.col.attribute = function(attribute) {
135       self$add.attribute(attribute = attribute, MARGIN = 2)
136     },
137     add.meta.data = function(meta.data) {
138       self$add.col.attribute(attribute = meta.data)
139     }
140   ),
141   private = list(
142     err_msg = "This loom object has not been created with either loomR::create or loomR::connect, please use these function to create or connect to a loom file",
143     load_attributes = function(MARGIN) {
144       attribute <- switch(
145         EXPR = MARGIN,
146         '1' = 'row_attrs',
147         '2' = 'col_attrs',
148         stop('Invalid attribute dimension')
149       )
150       group <- self[[attribute]]
151       attributes <- unlist(x = lapply(
152         X = names(x = group),
153         FUN = function(x) {
154           d <- list(group[[x]])
155           names(x = d) <- x
156           return(d)
157         }
158       ))
159       switch(
160         EXPR = MARGIN,
161         '1' = self$row.attrs <- attributes,
162         '2' = self$col.attrs <- attributes
163       )
164     },
165     load_layers = function() {
166       invisible(x = NULL)
167     }
168   )
169 )
170
171 #' Create a loom object
172 #'
173 #' @param filename ...
174 #' @param data ...
175 #' @param row.attrs ...
176 #' @param col.attrs ...
177 #' @param chunk.dims ...
178 #'
179 #' @return A connection to a loom file
180 #'
181 #' @importFrom utils packageVersion
182 #'
183 #' @seealso \code{\link{loom-class}}
184 #'
185 create <- function(
186   filename,
187   data,
188   row.attrs = NULL,
189   col.attrs = NULL,
190   layers = NULL,
191   chunk.dims = 'auto'
192 ) {
193   if (file.exists(filename)) {
194     stop(paste('File', file, 'already exists!'))
195   }
196   if (!is.matrix(x = data)) {
197     data <- as.matrix(x = data)
198   }
199   if (length(x = chunk.dims) > 2 || length(x = chunk.dims < 1)) {
200     stop("'chunk.dims' must be a one- or two-length integer vector or 'auto'")
201   } else if (length(x = chunk.dims == 1)) {
202     if (!grepl(pattern = '^auto$', x = chunk.dims, perl = TRUE)) {
203       chunk.dims <- rep.int(x = as.integer(x = chunk.dims), times = 2)
204     }
205   } else {
206     chunk.dims <- as.integer(x = chunk.dims)
207   }
208   new.loom <- loom$new(filename = filename, mode = 'w-')
209   h5attr(x = new.loom, which = 'version') <- as.character(x = packageVersion(pkg = 'loomR'))
210   new.loom$create_dataset(
211     name = 'matrix',
212     robj = t(x = data),
213     chunk_dims = chunk.dims
214   )
215   # Groups
216   new.loom$create_group(name = 'layers')
217   new.loom$create_group(name = 'row_attrs')
218   new.loom$create_group(name = 'col_attrs')
219   # Add layers
220   for (ly in layers) {
221     new.loom$add.layer(layer = ly)
222   }
223   for (rw in row.attrs) {
224     new.loom$add.row.attribute(attribute = rw)
225   }
226   for (cl in col.attrs) {
227     new.loom$add.col.attribute(attribute = cl)
228   }
229   # Set last bit of information
230   new.loom$shape <- ''
231   new.loom$chunksize <- ''
232   # Return the connection
233   return(new.loom)
234 }
235
236 # #' @importFrom utils packageVersion
237 # #'
238 # setMethod(
239 #   f = 'initialize',
240 #   signature = 'loom',
241 #   definition = function(.Object, name, mode = 'a') {
242 #     .Object <- callNextMethod(
243 #       .Object,
244 #       name = name,
245 #       mode = mode
246 #     )
247 #     validateLoom(object = .Object)
248 #     #.Object@version <- packageVersion(pkg = 'loom')
249 #     # .Object@filename <- name
250 #     .Object@shape <- dim(.Object['/matrix'])
251 #     return(.Object)
252 #   }
253 # )
254
255
256 #' Validate a loom object
257 #'
258 #' @param object A loom object
259 #'
260 #' @return None, errors if object is an invalid loom object
261 #'
262 #' @export
263 #'
264 validateLoom <- function(object) {
265   # A loom file is a specific HDF5
266   # We need a dataset in /matrix that's a two-dimensional dense matrix
267   root.datasets <- list.datasets(object = object, path = '/', recursive = FALSE)
268   if (length(x = root.datasets) != 1) {
269     stop("There can only be one dataset at the root of the loom file")
270   }
271   if (root.datasets != 'matrix') {
272     stop("The root dataset must be called '/matrix'")
273   }
274   # There must be groups called '/col_attrs', '/row_attrs', and '/layers'
275   required.groups <- c('row_attrs', 'col_attrs', 'layers')
276   dim.matrix <- object[[root.datasets]]$dims # Rows x Columns
277   names(dim.matrix) <- required.groups[c(2, 1)]
278   root.groups <- list.groups(object = object, path = '/', recursive = FALSE)
279   group.msg <- paste0(
280     "There can only be three groups in the loom file: '",
281     paste(required.groups, collapse = "', '"),
282     "'"
283   )
284   if (length(x = root.groups) != 3) {
285     stop(group.msg)
286   }
287   if (!all(required.groups %in% root.groups)) {
288     stop(group.msg)
289   }
290   unlist(x = sapply(
291     X = required.groups[1:2],
292     FUN = function(group) {
293       if (length(x = list.groups(object = object[[group]], recursive = FALSE)) > 0) {
294         stop(paste("Group", group, "cannot have subgroups"))
295       }
296       if (length(x = list.attributes(object = object[[group]])) > 0) {
297         stop(paste("Group", group, "cannot have subattributes"))
298       }
299       for (dataset in list.datasets(object = object[[group]])) {
300         if (object[[paste(group, dataset, sep = '/')]]$dims != dim.matrix[group]) {
301           stop(paste("All datasets in group", group, "must be of length", required.groups[group]))
302         }
303       }
304     }
305   ))
306   for (dataset in list.datasets(object = object[['/layers']])) {
307     if (any(object[[paste('layers', dataset, sep = '/')]]$dims != dim.matrix)) {
308       stop(paste("All datasets in '/layers' must be", dim.matrix[1], 'by', dim.matrix[2]))
309     }
310   }
311 }
312
313 #' Connect to a loom file
314 #'
315 #' @param filename The loom file to connect to
316 #' @param mode How do we connect to it? Pass 'r' for read-only or 'r+' for read/write
317 #'
318 #' @return A loom file connection
319 #'
320 #' @export
321 #'
322 connect <- function(filename, mode = "r") {
323   new.loom <- loom$new(filename = filename, mode = mode)
324   return(new.loom)
325 }
326
327 #need to comment
328 #need to add progress bar
329 #but otherwise, pretty cool
330 #for paul to try :
331 # f <- connect("~/Downloads/10X43_1.loom")
332 # mean_var = map(f,f_list = c(mean,var),chunksize = 5000)
333 # nGene <- map(f, f_list = function(x) length(which(x>0)), MARGIN = 2)
334 map <- function(self, f_list = list(mean, var), MARGIN=1, chunksize=1000, selection) {
335   n_func = length(f_list)
336   if (n_func == 1) {
337     f_list <- list(f_list)
338   }
339   if (MARGIN == 1) {
340     results <- list()
341     for (j in 1:n_func) {
342       results[[j]] <- numeric(0)
343     }
344     rows_per_chunk <- chunksize
345     ix <- 1
346     while (ix <= self@shape[1]) {
347       rows_per_chunk <- min(rows_per_chunk, self@shape[1] - ix + 1)
348       chunk <- self["matrix"][ix:(ix + rows_per_chunk - 1), ]
349       for (j in 1:n_func) {
350         new_results <- apply(chunk, 1, FUN = f_list[[j]])
351         results[[j]] <- c(results[[j]], new_results)
352       }
353       ix <- ix + chunksize
354     }
355   }
356   if (MARGIN == 2) {
357     results <- list()
358     for (j in 1:n_func) {
359       results[[j]] <- numeric(0)
360     }
361     cols_per_chunk <- chunksize
362     ix <- 1
363     while (ix <= self@shape[2]) {
364       cols_per_chunk <- min(cols_per_chunk, self@shape[2] - ix + 1)
365       chunk <- self["matrix"][, ix:(ix + cols_per_chunk - 1)]
366       for (j in 1:n_func) {
367         new_results <- apply(chunk, 2, FUN = f_list[[j]])
368         results[[j]] <- c(results[[j]], new_results)
369       }
370       ix <- ix + chunksize
371     }
372   }
373   if (n_func == 1) {
374     results <- results[[1]]
375   }
376   return(results)
377 }