Orthogonal selection (#108)

DESCRIPTION

@@ -28,7 +28,7 @@ Imports:
 Encoding: UTF-8
 LazyData: true
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.3.1
+RoxygenNote: 7.3.2
 Suggests: 
     testthat,
     knitr,

NAMESPACE

@@ -23,6 +23,7 @@ export(ZarrGroup)
 export(ZlibCodec)
 export(ZstdCodec)
 export(as_scalar)
+export(int)
 export(is_key_error)
 export(is_scalar)
 export(is_slice)
@@ -39,4 +40,5 @@ export(zarr_open)
 export(zarr_open_array)
 export(zarr_open_group)
 export(zarr_save_array)
+export(zb_int)
 export(zb_slice)

R/array-nested.R

@@ -1,40 +1,53 @@
 #' @keywords internal
 zero_based_to_one_based <- function(selection, shape) {
 
-  if(!all(vapply(selection, is_slice, logical(length = 1)))) 
-    stop("selection must be a list of slices")
+  # drop this since we could do it for arbitrary indices
+  # if(!all(vapply(selection, is_slice, logical(length = 1)))) 
+  #   stop("selection must be a list of slices")
 
   selection_list <- list()
 
   for(i in seq_len(length(selection))) {
+
+    # get selection
     sel <- selection[[i]]
-    # We assume the selection uses zero-based indexing,
-    # and internally convert to R-based / 1-based indexing
-    # before accessing data on the internal self$data.
-    sel_start <- sel$start + 1 # Add one, since R indexing is zero-based.
-    sel_stop <- sel$stop # Do not subtract one, since R indexing is inclusive.
-    sel_step <- sel$step
-    if(is.na(sel_step)) sel_step <- 1
-    # TODO: convert these warnings to errors once we know internals do indexing correctly
-    if(sel_start < 1) {
-      sel_start <- 1
-      message("IndexError: NestedArray$get() received slice with start index out of bounds - too low")
-    }
-    if(sel_start > shape[i]) {
-      sel_start <- shape[i]
-      message("IndexError: NestedArray$get() received slice with start index out of bounds - too high")
-    }
-    if(sel_stop < 1) {
-      sel_stop <- 1
-      message("IndexError: NestedArray$get() received slice with stop index out of bounds - too low")
-    }
-    if(sel_stop > shape[i]) {
-      sel_stop <- shape[i]
-      message("IndexError: NestedArray$get() received slice with stop index out of bounds - too high")
+
+    # for slice
+    if(inherits(sel, "Slice")){
+
+      # We assume the selection uses zero-based indexing,
+      # and internally convert to R-based / 1-based indexing
+      # before accessing data on the internal self$data.
+      sel_start <- sel$start + 1 # Add one, since R indexing is zero-based.
+      sel_stop <- sel$stop # Do not subtract one, since R indexing is inclusive.
+      sel_step <- sel$step
+      if(is.na(sel_step)) sel_step <- 1
+      # TODO: convert these warnings to errors once we know internals do indexing correctly
+      if(sel_start < 1) {
+        sel_start <- 1
+        message("IndexError: NestedArray$get() received slice with start index out of bounds - too low")
+      }
+      if(sel_start > shape[i]) {
+        sel_start <- shape[i]
+        message("IndexError: NestedArray$get() received slice with start index out of bounds - too high")
+      }
+      if(sel_stop < 1) {
+        sel_stop <- 1
+        message("IndexError: NestedArray$get() received slice with stop index out of bounds - too low")
+      }
+      if(sel_stop > shape[i]) {
+        sel_stop <- shape[i]
+        message("IndexError: NestedArray$get() received slice with stop index out of bounds - too high")
+      }
+      selection_list <- append(selection_list, list(seq(from = sel_start, 
+                                                        to = sel_stop, 
+                                                        by = sel_step))) 
+    } else if(is.numeric(sel)) {
+      sel <- sel + 1
+      selection_list <- append(selection_list, list(sel))
+    } else {
+      stop("Unsupported selection type")
     }
-    selection_list <- append(selection_list, list(seq(from = sel_start, 
-                                                      to = sel_stop, 
-                                                      by = sel_step)))
   }
   return(selection_list)
 }

R/atomic.R

@@ -23,7 +23,7 @@ is_scalar <- function(s) {
 #' Check if a value is an integer R vector or scalar.
 #' @keywords internal
 is_integer <- function(s) {
-  if(is.atomic(s) && is.numeric(s) && all(s %% 1 == 0)) {
+  if(is.atomic(s) && is.numeric(s) && all(s %% 1 == 0) && length(s) == 1) {
     return(TRUE)
   }
   return(FALSE)
@@ -42,8 +42,10 @@ is_integer_scalar <- function(s) {
 #' explicitly tagged as a scalar.
 #' @keywords internal
 is_integer_vec <- function(s) {
-  if(!is_scalar(s) && is_integer(s)) {
-    return(TRUE)
+  if(!is_scalar(s) && is.vector(s) && !is.list(s) && all(sapply(s,is_integer))) {
+    if(length(s) > 1){
+      return(TRUE)
+    }
   }
   return(FALSE)
 }

R/filters.R

@@ -0,0 +1,52 @@
+# transforming filters to be passed to ZarrArray$get_orthogonal_selection()
+# 
+# a:b => slice(a,b)
+# seq(from, to, by) => slice(start, stop, step) ? for now indices of seq(from, to, by) are passed to get_orthogonal_selection (check below, TODO)
+# c(a,b,c) => c(a,b,c), combine elements are passed as indices
+# empty dimension => return everything
+# 
+manage_filters <- function(filters) {
+  lapply(filters, function(x) {
+    # Proceed based on type of filter
+    if(typeof(x) == "symbol") {
+      # When empty dimension, return everything
+      if(x == "") {
+        return(NULL)
+      } else {
+        stop("Unsupported filter '", as.character(x), "' supplied") 
+      }
+    } else if(typeof(x) == "double") {
+      # Return single value for dimension
+      return(slice(x, x))
+    } else if(typeof(x) == "language") {
+      x <- as.list(x)
+      # Return a range (supplied via : or seq())
+      if(x[[1]] == ":") {
+        return(slice(x[[2]], x[[3]]))
+      } else if(x[[1]] == "seq") {
+        # TODO: do we need slicing for this case ? otherwise implement slice(start, stop, step)
+        arg_names <- names(x)
+        from <- ifelse("from" %in% arg_names, x[[which("from" == arg_names)]], x[[2]])
+        to <- ifelse("to" %in% arg_names, x[[which("to" == arg_names)]], x[[3]])
+        if(length(x) > 3) {
+          by <- ifelse("by" %in% arg_names, x[[which("by" == arg_names)]], x[[4]])
+          return(int(seq(from, to, by)))
+        } else {
+          by <- NA
+          return(int(seq(from, to)))
+        }
+        return(int(seq(from, to, by)))
+      } else if(x[[1]] == "c") {
+        # return elements of the combine function as indices
+        check_func <- sapply(x, function(y) {
+          !is.function(eval(y))
+        })
+        return(int(floor(unlist(x[check_func]))))
+      } else {
+        stop("Unsupported filter '", as.character(x), "' supplied")
+      }
+    } else {
+      stop("Unsupported filter '", as.character(x), "' supplied")
+    }
+  })
+}