Support domain range setting in queries

R/TileDBArray.R

@@ -442,6 +442,18 @@ setMethod("[", "tiledb_array",
   ## ranges seem to interfere with the byte/element adjustment below so set up toggle
   rangeunset <- TRUE
 
+  ## expand a shorter-but-named selected_ranges list
+  if (   (length(x@selected_ranges) < length(dimnames))
+      && (!is.null(names(x@selected_ranges)))          ) {
+      fulllist <- vector(mode="list", length=length(dimnames))
+      ind <- match(names(x@selected_ranges), dimnames)
+      if (any(is.na(ind))) stop("Name for selected ranges does not match dimension names.")
+      for (ii in seq_len(length(ind))) {
+          fulllist[[ ind[ii] ]] <- x@selected_ranges[[ii]]
+      }
+      x@selected_ranges <- fulllist
+  }
+
   ## set default range(s) on first dimension if nothing is specified
   if (is.null(i) &&
       (length(x@selected_ranges) == 0 ||
@@ -504,7 +516,13 @@ setMethod("[", "tiledb_array",
         qryptr <- libtiledb_query_add_range_with_type(qryptr, k-1, dimtypes[k], vec[1], vec[2])
       }
       rangeunset <- FALSE
+    } else if (k > 2) {                 # cases 1 and 2 covered above in 'i' and 'j' case
+      #cat("Adding null dim", k, "\n")
+      vec <- .mapDatetime2integer64(nonemptydom[[k]], dimtypes[k])
+      qryptr <- libtiledb_query_add_range_with_type(qryptr, k-1, dimtypes[k], vec[1], vec[2])
+      rangeunset <- FALSE
     }
+
   }
 
   ## retrieve est_result_size

inst/tinytest/test_dimsubset.R

@@ -0,0 +1,100 @@
+
+## this test file has an implicit dependency on package 'nycflights13'
+
+library(tinytest)
+library(tiledb)
+
+isOldWindows <- Sys.info()[["sysname"]] == "Windows" && grepl('Windows Server 2008', osVersion)
+if (isOldWindows) exit_file("skip this file on old Windows releases")
+
+if (!requireNamespace("nycflights13", quietly=TRUE)) exit_file("Needed 'nycflights13' package missing")
+
+ctx <- tiledb_ctx(limitTileDBCores())
+
+if (tiledb_version(TRUE) < "2.0.0") exit_file("TileDB Array types required TileDB 2.0.* or greater")
+
+op <- options()
+options(stringsAsFactors=FALSE)       # accomodate R 3.*
+dir.create(tmp <- tempfile())
+
+library(nycflights13)
+
+dom <- tiledb_domain(dims = c(tiledb_dim("carrier", NULL, NULL, "ASCII"),
+                              tiledb_dim("origin", NULL, NULL, "ASCII"),
+                              tiledb_dim("dest", NULL, NULL, "ASCII"),
+                              tiledb_dim("time_hour",
+                                         c(as.POSIXct("2012-01-01 00:00:00"),
+                                           as.POSIXct("2014-12-31 23:59:99")), 1000, "DATETIME_SEC")))
+
+sch <- tiledb_array_schema(dom,
+                           attrs <- c(tiledb_attr("year", type = "INT32"),
+                                      tiledb_attr("month", type = "INT32"),
+                                      tiledb_attr("day", type = "INT32"),
+                                      tiledb_attr("dep_time", type = "INT32", nullable = TRUE),
+                                      tiledb_attr("sched_dep_time", type = "INT32"),
+                                      tiledb_attr("dep_delay", type = "FLOAT64", nullable = TRUE),
+                                      tiledb_attr("arr_time", type = "INT32"),
+                                      tiledb_attr("sched_arr_time", type = "INT32"),
+                                      tiledb_attr("arr_delay", type = "FLOAT64", nullable = TRUE),
+                                      tiledb_attr("flight", type = "INT32", nullable = TRUE),
+                                      tiledb_attr("tailnum", type = "ASCII", ncells = NA, nullable = TRUE),
+                                      tiledb_attr("air_time", type = "FLOAT64", nullable = TRUE),
+                                      tiledb_attr("distance", type = "FLOAT64"),
+                                      tiledb_attr("hour", type = "FLOAT64"),
+                                      tiledb_attr("minute", type = "FLOAT64")),
+                           sparse = TRUE,
+                           allows_dups = TRUE)
+res <- tiledb_array_create(tmp, sch)
+
+arr <- tiledb_array(res)
+## we reorder the data.frame / tibble on the fly, and yes there are a number of ways to do this
+arr[] <- list(carrier = flights$carrier,
+              origin = flights$origin,
+              dest = flights$dest,
+              time_hour = flights$time_hour,
+              year = flights$year,
+              month = flights$month,
+              day = flights$day,
+              dep_time = flights$dep_time,
+              sched_dep_time = flights$sched_dep_time,
+              dep_delay = flights$dep_delay,
+              arr_time = flights$arr_time,
+              sched_arr_time = flights$sched_arr_time,
+              arr_delay = flights$arr_delay,
+              flight = flights$flight,
+              tailnum = flights$tailnum,
+              air_time = flights$air_time,
+              distance = flights$distance,
+              hour = flights$hour,
+              minute = flights$minute)
+
+newarr <- tiledb_array(tmp, as.data.frame=TRUE)
+dat <- newarr[]
+expect_equal(nrow(dat), nrow(flights))
+## compare some columns, as we re-order comparing all trickers
+expect_equal(dat$carrier, sort(as.character(flights$carrier)))
+expect_equal(table(dat$origin), table(flights$origin))
+
+selected_ranges(newarr) <- list(cbind("AA","AA"),
+                                cbind("JFK","JFK"),
+                                cbind("BOS", "BOS"),
+                                NULL)
+dat <- newarr[]
+expect_equal(unique(dat$carrier), "AA")
+expect_equal(unique(dat$origin), "JFK")
+expect_equal(unique(dat$dest), "BOS")
+
+selected_ranges(newarr) <- list(dest = cbind("BOS", "BOS"), origin = cbind("LGA", "LGA"))
+dat <- newarr[]
+expect_equal(unique(dat$dest), "BOS")
+expect_equal(unique(dat$origin), "LGA")
+
+selected_ranges(newarr) <- list(origin = cbind("JFK", "JFK"), carrier = cbind("AA", "AA"))
+dat <- newarr[]
+expect_equal(unique(dat$carrier), "AA")
+expect_equal(unique(dat$origin), "JFK")
+
+selected_ranges(newarr) <- list(dest = cbind("BOS", "BOS"), origin = cbind("JFK", "LGA"))
+dat <- newarr[]
+expect_equal(unique(dat$origin), c("JFK", "LGA"))
+expect_equal(unique(dat$dest), "BOS")