Merge pull request #59 from jiajic/dev

Add: basic DT-based object subsetting

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: GiottoClass
 Title: Giotto Suite object definitions and framework
-Version: 0.0.0.9006
+Version: 0.0.0.9007
 Authors@R: c(
 	person("Ruben", "Dries", email = "rubendries@gmail.com",
 		 role = c("aut", "cre")),

R/classes.R

@@ -33,17 +33,27 @@ setClassUnion('gIndex', c('numeric', 'logical', 'character'))
 
 
 
-
-
 # VIRTUAL CLASSES ####
 
+
 # ** giottoSubobject Class ####
 #' @keywords internal
 #' @noRd
 setClass(
   'giottoSubobject',
   contains = 'VIRTUAL')
 
+# ** gdtData Class ####
+#' @description
+#' umbrella class for referring to Giotto's normal data.table-based slots for
+#' extraction purposes
+#' @keywords internal
+#' @noRd
+setClass(
+  'gdtData',
+  contains = 'VIRTUAL'
+)
+
 
 # ** nameData Class ####
 #' @keywords internal
@@ -76,7 +86,7 @@ setClass("exprData",
 #' @keywords internal
 #' @noRd
 setClass("coordDataDT",
-  contains = "VIRTUAL",
+  contains = c("VIRTUAL", "gdtData"),
   slots = list(coordinates = "data.table"),
   prototype = prototype(coordinates = data.table::data.table())
 )
@@ -99,7 +109,7 @@ setClass("coordDataDT",
 #' @keywords internal
 #' @noRd
 setClass("metaData",
-  contains = "VIRTUAL",
+  contains = c("VIRTUAL", "gdtData"),
   slots = list(
     metaDT = "data.table",
     col_desc = "character"
@@ -119,7 +129,7 @@ setClass("metaData",
 #' @keywords internal
 #' @noRd
 setClass("enrData",
-  contains = "VIRTUAL",
+  contains = c("VIRTUAL", "gdtData"),
   slots = list(
     method = "character",
     enrichDT = "nullOrDatatable"

R/methods-extract.R

@@ -90,6 +90,61 @@ setMethod('$<-', signature(x = 'terraVectData'),
 
 # [ S4 access generic ####
 
+## * gdtData ####
+
+# Make it so that i and j subsets can be written independently
+#' @rdname extract-methods
+#' @export
+setMethod('[', signature(x = 'gdtData', i = 'ANY', j = 'ANY', drop = 'missing'),
+          function(x, i, j) {
+            x = x[i = i]
+            x = x[j = j]
+            x
+          })
+
+#' @rdname extract-methods
+#' @export
+setMethod('[', signature(x = 'gdtData', i = 'logical', j = 'missing', drop = 'missing'),
+          function(x, i, j) {
+            x_nrow = nrow(x)
+            i_len = length(i)
+
+            if(i_len > x_nrow) {
+              stop('logical subset vector is longer than number of rows',
+                   call. = FALSE)
+            }
+            if (i_len < x_nrow) { # handle recycling
+              i = rep(i, length.out = x_nrow)
+            }
+
+            x[] = x[][i]
+            x
+          })
+
+#' @rdname extract-methods
+#' @export
+setMethod('[', signature(x = 'gdtData', i = 'character', j = 'missing', drop = 'missing'),
+          function(x, i, j) {
+
+            # only appropriate for objects where the spatIDs are in the same
+            # order and number of repeats as the contained data.table
+            x_colnames = colnames(x[])
+            ids = if('cell_ID' %in% x_colnames) spatIDs(x)
+            else if('feat_ID' %in% x_colnames) featIDs(x)
+            else stop(wrap_txt(
+              'Subset object does not contain either cell_ID or feat_ID column'
+            ))
+
+            # make idx vector
+            idx = match(i, ids)
+            x[] = x[][idx]
+            x
+          })
+
+
+
+
+
 ## * coordDataDT ####
 
 
@@ -104,7 +159,6 @@ setMethod('[', signature(x = 'coordDataDT', i = 'missing', j = 'ANY', drop = 'mi
             x
           })
 
-
 # setMethod('[', signature(x = 'giotto', i = 'character', j = 'missing', drop = 'missing'),
 #           function(x, i, spat_unit = NULL, feat_type = NULL, name = NULL) {
 #
@@ -184,7 +238,7 @@ setReplaceMethod('[', signature(x = 'coordDataDT', i = 'missing', j = 'missing',
 
 #' @rdname extract-methods
 #' @export
-setMethod('[', signature(x = 'giottoPoints', i = "ANY", j = "missing", drop = "missing"),
+setMethod('[', signature(x = 'giottoPoints', i = "gIndex", j = "missing", drop = "missing"),
           function(x, i, j) {
             x@spatVector = x@spatVector[i]
             x@unique_ID_cache = featIDs(x, uniques = TRUE, use_cache = FALSE)