diff --git a/DESCRIPTION b/DESCRIPTION index a4c5f9a5a1..71591793f8 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: tiledb Type: Package -Version: 0.30.2.1 +Version: 0.30.2.3 Title: Modern Database Engine for Complex Data Based on Multi-Dimensional Arrays Authors@R: c( person("TileDB, Inc.", role = c("aut", "cph")), diff --git a/NEWS.md b/NEWS.md index fc1e7d0951..c593759854 100644 --- a/NEWS.md +++ b/NEWS.md @@ -4,6 +4,8 @@ * Run `clang-format` on non-autogen C++ source code * Update unit tests to expect dense current domain * Support parentheses in query conditions +* memory alloc: Accomodate zero buffer size estimate v2 +* Apply `styler::style_pkg()` # tiledb 0.30.2 diff --git a/R/Array.R b/R/Array.R index cd2ad136f9..db7417aff1 100644 --- a/R/Array.R +++ b/R/Array.R @@ -28,7 +28,9 @@ #' in case the array should be encryption. #' #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' \dontrun{ #' pth <- tempdir() #' dom <- tiledb_domain(dims = c(tiledb_dim("d1", c(1L, 10L), type = "INT32"))) @@ -38,26 +40,28 @@ #' } #' #' @export -tiledb_array_create <- function(uri, schema, encryption_key) { #, ctx = tiledb_get_context()) { - stopifnot("The 'uri' argument must be a string scalar" = !missing(uri) && is.scalar(uri, "character"), - "The 'schema' argument must be a tiledb_array_schema object" = !missing(schema) && is(schema, "tiledb_array_schema")) - if (!missing(encryption_key)) { - ## old interface - needreset <- FALSE - config <- oldconfig <- tiledb_config() - if (config["sm.encryption_type"] != "AES_256_GCM" || - config["sm.encryption_key"] != encryption_key) { - config["sm.encryption_type"] <- "AES_256_GCM" - config["sm.encryption_key"] <- encryption_key - ctx <- tiledb::tiledb_ctx(config) - needreset <- TRUE - } - uri <- libtiledb_array_create(uri, schema@ptr) - if (needreset) ctx <- tiledb::tiledb_ctx(oldconfig) - invisible(uri) - } else { - invisible(libtiledb_array_create(uri, schema@ptr)) +tiledb_array_create <- function(uri, schema, encryption_key) { # , ctx = tiledb_get_context()) { + stopifnot( + "The 'uri' argument must be a string scalar" = !missing(uri) && is.scalar(uri, "character"), + "The 'schema' argument must be a tiledb_array_schema object" = !missing(schema) && is(schema, "tiledb_array_schema") + ) + if (!missing(encryption_key)) { + ## old interface + needreset <- FALSE + config <- oldconfig <- tiledb_config() + if (config["sm.encryption_type"] != "AES_256_GCM" || + config["sm.encryption_key"] != encryption_key) { + config["sm.encryption_type"] <- "AES_256_GCM" + config["sm.encryption_key"] <- encryption_key + ctx <- tiledb::tiledb_ctx(config) + needreset <- TRUE } + uri <- libtiledb_array_create(uri, schema@ptr) + if (needreset) ctx <- tiledb::tiledb_ctx(oldconfig) + invisible(uri) + } else { + invisible(libtiledb_array_create(uri, schema@ptr)) + } } ##' Open a TileDB Array @@ -68,11 +72,14 @@ tiledb_array_create <- function(uri, schema, encryption_key) { #, ctx = tiledb_g ##' @return The TileDB Array object but opened for reading or writing ##' @importFrom methods .hasSlot ##' @export -tiledb_array_open <- function(arr, - type = if (tiledb_version(TRUE) >= "2.12.0") - c("READ", "WRITE", "DELETE", "MODIFY_EXCLUSIVE") - else - c("READ", "WRITE")) { +tiledb_array_open <- function( + arr, + type = if (tiledb_version(TRUE) >= "2.12.0") { + c("READ", "WRITE", "DELETE", "MODIFY_EXCLUSIVE") + } else { + c("READ", "WRITE") + } +) { stopifnot("The 'arr' argument must be a tiledb_array object" = .isArray(arr)) type <- match.arg(type) @@ -92,9 +99,11 @@ tiledb_array_open <- function(arr, ##' @param timestamp A Datetime object that will be converted to millisecond granularity ##' @return The TileDB Array object but opened for reading or writing ##' @export -tiledb_array_open_at <- function(arr, type=c("READ","WRITE"), timestamp) { - stopifnot("The 'arr' argument must be a tiledb_array object" = .isArray(arr), - "The 'timestamp' argument must be a time object" = inherits(timestamp, "POSIXct")) +tiledb_array_open_at <- function(arr, type = c("READ", "WRITE"), timestamp) { + stopifnot( + "The 'arr' argument must be a tiledb_array object" = .isArray(arr), + "The 'timestamp' argument must be a time object" = inherits(timestamp, "POSIXct") + ) type <- match.arg(type) ctx <- tiledb_get_context() if (.hasSlot(arr, "encryption_key") && length(arr@encryption_key) > 0) { @@ -123,8 +132,8 @@ tiledb_array_close <- function(arr) { ##' @return A boolean indicating whether the TileDB Array object is open ##' @export tiledb_array_is_open <- function(arr) { - stopifnot("The 'arr' argument must be a tiledb_array object" = .isArray(arr)) - libtiledb_array_is_open(arr@ptr) + stopifnot("The 'arr' argument must be a tiledb_array object" = .isArray(arr)) + libtiledb_array_is_open(arr@ptr) } ##' Check for Homogeneous Domain @@ -137,8 +146,10 @@ tiledb_array_is_homogeneous <- function(arr) { ## there is a non-exported call at the C level we could use instead sch <- schema(arr) dom <- domain(sch) - domaintype <- sapply(libtiledb_domain_get_dimensions(dom@ptr), - libtiledb_dim_get_datatype) + domaintype <- sapply( + libtiledb_domain_get_dimensions(dom@ptr), + libtiledb_dim_get_datatype + ) n <- length(unique(domaintype)) n == 1 } @@ -153,8 +164,10 @@ tiledb_array_is_heterogeneous <- function(arr) { ## there is a non-exported call at the C level we could use instead sch <- schema(arr) dom <- domain(sch) - domaintype <- sapply(libtiledb_domain_get_dimensions(dom@ptr), - libtiledb_dim_get_datatype) + domaintype <- sapply( + libtiledb_domain_get_dimensions(dom@ptr), + libtiledb_dim_get_datatype + ) n <- length(unique(domaintype)) n > 1 } @@ -167,30 +180,44 @@ tiledb_array_is_heterogeneous <- function(arr) { ##' @param ctx A tiledb_ctx object (optional) ##' @return A boolean indicating success ##' @export -tiledb_array_delete_fragments <- function(arr, ts_start, ts_end, ctx = tiledb_get_context()) { - stopifnot("The 'arr' argument must be a tiledb_array object" = .isArray(arr), - "The 'ts_start' argument must be a time object" = inherits(ts_start, "POSIXct"), - "The 'ts_end' argument must be a time object" = inherits(ts_end, "POSIXct")) - libtiledb_array_delete_fragments(ctx@ptr, arr@ptr, ts_start, ts_end) - invisible(TRUE) +tiledb_array_delete_fragments <- function( + arr, + ts_start, + ts_end, + ctx = tiledb_get_context() +) { + stopifnot( + "The 'arr' argument must be a tiledb_array object" = .isArray(arr), + "The 'ts_start' argument must be a time object" = inherits(ts_start, "POSIXct"), + "The 'ts_end' argument must be a time object" = inherits(ts_end, "POSIXct") + ) + libtiledb_array_delete_fragments(ctx@ptr, arr@ptr, ts_start, ts_end) + invisible(TRUE) } ##' Delete fragments written given by their URIs ##' -##' @param arr A TileDB Array object as for example returned by \code{tiledb_array()} +##' @param arr A TileDB Array object as for example returned by +##' \code{tiledb_array()} ##' @param fragments A character vector with fragment URIs ##' @param ctx A tiledb_ctx object (optional) ##' @return A boolean indicating success ##' @export -tiledb_array_delete_fragments_list <- function(arr, fragments, ctx = tiledb_get_context()) { - stopifnot("The 'arr' argument must be a tiledb_array object" = .isArray(arr), - "The 'fragments' argument must be a character vector" = is.character(fragments)) - if (tiledb_version(TRUE) >= "2.18.0") { - libtiledb_array_delete_fragments_list(ctx@ptr, arr@ptr, fragments) - } else { - message("This function is only available with TileDB 2.18.0 or later") - } - invisible(TRUE) +tiledb_array_delete_fragments_list <- function( + arr, + fragments, + ctx = tiledb_get_context() +) { + stopifnot( + "The 'arr' argument must be a tiledb_array object" = .isArray(arr), + "The 'fragments' argument must be a character vector" = is.character(fragments) + ) + if (tiledb_version(TRUE) >= "2.18.0") { + libtiledb_array_delete_fragments_list(ctx@ptr, arr@ptr, fragments) + } else { + message("This function is only available with TileDB 2.18.0 or later") + } + invisible(TRUE) } ##' Check for Enumeration (aka Factor aka Dictionary) @@ -199,13 +226,13 @@ tiledb_array_delete_fragments_list <- function(arr, fragments, ctx = tiledb_get_ ##' @return A boolean indicating if the array has homogeneous domains ##' @export tiledb_array_has_enumeration <- function(arr) { - stopifnot("The 'arr' argument must be a tiledb_array object" = .isArray(arr)) - ctx <- tiledb_get_context() - if (!tiledb_array_is_open(arr)) { - arr <- tiledb_array_open(arr, "READ") - on.exit(tiledb_array_close(arr)) - } - return(libtiledb_array_has_enumeration_vector(ctx@ptr, arr@ptr)) + stopifnot("The 'arr' argument must be a tiledb_array object" = .isArray(arr)) + ctx <- tiledb_get_context() + if (!tiledb_array_is_open(arr)) { + arr <- tiledb_array_open(arr, "READ") + on.exit(tiledb_array_close(arr)) + } + return(libtiledb_array_has_enumeration_vector(ctx@ptr, arr@ptr)) } ##' Run an aggregate query on the given (sparse) array and attribute @@ -219,27 +246,33 @@ tiledb_array_has_enumeration <- function(arr) { ##' @param nullable A boolean toggle whether the attribute is nullable ##' @return The value of the aggregation ##' @export -tiledb_array_apply_aggregate <- function(array, attrname, - operation = c("Count", "NullCount", "Min", "Max", - "Mean", "Sum"), - nullable = TRUE) { - stopifnot("The 'array' argument must be a TileDB Array object" = is(array, "tiledb_array"), - "The 'array' must be a sparse TileDB Array" = is.sparse(schema(array)), - "The 'attrname' argument must be character" = is.character(attrname), - "The 'operation' argument must be character" = is.character(operation), - "The 'nullable' argument must be logical" = is.logical(nullable)) +tiledb_array_apply_aggregate <- function( + array, + attrname, + operation = c("Count", "NullCount", "Min", "Max", "Mean", "Sum"), + nullable = TRUE +) { + stopifnot( + "The 'array' argument must be a TileDB Array object" = is(array, "tiledb_array"), + "The 'array' must be a sparse TileDB Array" = is.sparse(schema(array)), + "The 'attrname' argument must be character" = is.character(attrname), + "The 'operation' argument must be character" = is.character(operation), + "The 'nullable' argument must be logical" = is.logical(nullable) + ) - operation <- match.arg(operation) + operation <- match.arg(operation) - if (tiledb_array_is_open(array)) - array <- tiledb_array_close(array) + if (tiledb_array_is_open(array)) { + array <- tiledb_array_close(array) + } - query <- tiledb_query(array, "READ") + query <- tiledb_query(array, "READ") - if (! tiledb_query_get_layout(query) %in% c("UNORDERED", "GLOBAL_ORDER")) - query <- tiledb_query_set_layout(query, "UNORDERED") + if (!tiledb_query_get_layout(query) %in% c("UNORDERED", "GLOBAL_ORDER")) { + query <- tiledb_query_set_layout(query, "UNORDERED") + } - libtiledb_query_apply_aggregate(query@ptr, attrname, operation, nullable) + libtiledb_query_apply_aggregate(query@ptr, attrname, operation, nullable) } ##' Upgrade an Array to the current TileDB Array Schema Format @@ -249,10 +282,18 @@ tiledb_array_apply_aggregate <- function(array, attrname, ##' @param ctx A tiledb_ctx object (optional) ##' @return Nothing is returned as the function is invoked for its side effect ##' @export -tiledb_array_upgrade_version <- function(array, config = NULL, ctx = tiledb_get_context()) { - stopifnot("The 'array' argument must be a TileDB Array object" = is(array, "tiledb_array"), - "The 'config' argument must be NULL or a TileDB Config" = - is.null(config) || is(config, "tiledb_config")) - libtiledb_array_upgrade_version(ctx@ptr, array@ptr, array@uri, - if (is.null(config)) NULL else config@ptr) +tiledb_array_upgrade_version <- function( + array, + config = NULL, + ctx = tiledb_get_context() +) { + stopifnot( + "The 'array' argument must be a TileDB Array object" = is(array, "tiledb_array"), + "The 'config' argument must be NULL or a TileDB Config" = + is.null(config) || is(config, "tiledb_config") + ) + libtiledb_array_upgrade_version( + ctx@ptr, array@ptr, array@uri, + if (is.null(config)) NULL else config@ptr + ) } diff --git a/R/ArraySchema.R b/R/ArraySchema.R index 29ed9baaa4..173a8fef17 100644 --- a/R/ArraySchema.R +++ b/R/ArraySchema.R @@ -26,13 +26,17 @@ #' @slot arrptr An optional external pointer to the underlying array, or NULL if missing #' @exportClass tiledb_array_schema setClass("tiledb_array_schema", - slots = list(ptr = "externalptr", - arrptr = "ANY")) - -tiledb_array_schema.from_ptr <- function(ptr, arrptr=NULL) { - stopifnot("The 'ptr' argument must be an external pointer to a tiledb_array_schema instance" - = !missing(ptr) && is(ptr, "externalptr") && !is.null(ptr)) - new("tiledb_array_schema", ptr = ptr, arrptr = arrptr) + slots = list( + ptr = "externalptr", + arrptr = "ANY" + ) +) + +tiledb_array_schema.from_ptr <- function(ptr, arrptr = NULL) { + stopifnot( + "The 'ptr' argument must be an external pointer to a tiledb_array_schema instance" = !missing(ptr) && is(ptr, "externalptr") && !is.null(ptr) + ) + new("tiledb_array_schema", ptr = ptr, arrptr = arrptr) } #' Constructs a `tiledb_array_schema` object @@ -50,73 +54,90 @@ tiledb_array_schema.from_ptr <- function(ptr, arrptr=NULL) { #' @param enumerations (optional) named list of enumerations #' @param ctx tiledb_ctx object (optional) #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' schema <- tiledb_array_schema( -#' dom = tiledb_domain( -#' dims = c(tiledb_dim("rows", c(1L, 4L), 4L, "INT32"), -#' tiledb_dim("cols", c(1L, 4L), 4L, "INT32"))), -#' attrs = c(tiledb_attr("a", type = "INT32")), -#' cell_order = "COL_MAJOR", -#' tile_order = "COL_MAJOR", -#' sparse = FALSE) +#' dom = tiledb_domain( +#' dims = c( +#' tiledb_dim("rows", c(1L, 4L), 4L, "INT32"), +#' tiledb_dim("cols", c(1L, 4L), 4L, "INT32") +#' ) +#' ), +#' attrs = c(tiledb_attr("a", type = "INT32")), +#' cell_order = "COL_MAJOR", +#' tile_order = "COL_MAJOR", +#' sparse = FALSE +#' ) #' schema #' #' @export -tiledb_array_schema <- function(domain, - attrs, - cell_order = "COL_MAJOR", - tile_order = "COL_MAJOR", - sparse = FALSE, - coords_filter_list = NULL, - offsets_filter_list = NULL, - validity_filter_list = NULL, - capacity = 10000L, - allows_dups = FALSE, - enumerations = NULL, - ctx = tiledb_get_context()) { - if (!missing(attrs) && length(attrs) != 0) { - is_attr <- function(obj) is(obj, "tiledb_attr") - if (is_attr(attrs)) # if an attrs object given: - attrs <- list(attrs) # make it a list so that lapply works below - stopifnot("length of 'attrs' cannot be zero" = length(attrs) > 0, - "'attrs' must be a list of one or tiled_attr objects" = all(vapply(attrs, is_attr, logical(1)))) - } else { - attrs <- NULL - } - stopifnot("ctx argument must be a tiledb_ctx" = is(ctx, "tiledb_ctx"), - "domain argument must be a tiledb::Domain" = !missing(domain) && is(domain, "tiledb_domain"), - "cell_order argument must be a scalar string" = is.scalar(cell_order, "character"), - "tile_order argument must be a scalar string" = is.scalar(tile_order, "character"), - "coords_filter_list must be a filter list" = is.null(coords_filter_list) || is(coords_filter_list, "tiledb_filter_list"), - "offsets_filter_list must be a filter_list" = is.null(offsets_filter_list) || is(offsets_filter_list, "tiledb_filter_list"), - "validity_filter_list must be a_filter_list" = is.null(validity_filter_list) || is(validity_filter_list, "tiledb_filter_list"), - "'sparse' must be TRUE or FALSE" = is.logical(sparse), - "'allows_dups' must be TRUE or FALSE" = is.logical(allows_dups), - "'allows_dups' requires 'sparse' TRUE" = !allows_dups || sparse) - #if (allows_dups && !sparse) stop("'allows_dups' requires 'sparse' TRUE") - - attr_ptr_list <- if (is.list(attrs)) lapply(attrs, function(obj) slot(obj, "ptr")) else list() - coords_filter_list_ptr <- if (!is.null(coords_filter_list)) coords_filter_list@ptr else NULL - offsets_filter_list_ptr <- if (!is.null(offsets_filter_list)) offsets_filter_list@ptr else NULL - validity_filter_list_ptr <- if (!is.null(validity_filter_list)) validity_filter_list@ptr else NULL - - ptr <- libtiledb_array_schema(ctx@ptr, domain@ptr, attr_ptr_list, cell_order, tile_order, - coords_filter_list_ptr, offsets_filter_list_ptr, - validity_filter_list_ptr, sparse, enumerations) - libtiledb_array_schema_set_capacity(ptr, capacity) - if (allows_dups) libtiledb_array_schema_set_allows_dups(ptr, TRUE) - invisible(new("tiledb_array_schema", ptr = ptr)) +tiledb_array_schema <- function( + domain, + attrs, + cell_order = "COL_MAJOR", + tile_order = "COL_MAJOR", + sparse = FALSE, + coords_filter_list = NULL, + offsets_filter_list = NULL, + validity_filter_list = NULL, + capacity = 10000L, + allows_dups = FALSE, + enumerations = NULL, + ctx = tiledb_get_context() +) { + if (!missing(attrs) && length(attrs) != 0) { + is_attr <- function(obj) is(obj, "tiledb_attr") + if (is_attr(attrs)) { # if an attrs object given: + attrs <- list(attrs) + } # make it a list so that lapply works below + stopifnot( + "length of 'attrs' cannot be zero" = length(attrs) > 0, + "'attrs' must be a list of one or tiled_attr objects" = all(vapply(attrs, is_attr, logical(1))) + ) + } else { + attrs <- NULL + } + stopifnot( + "ctx argument must be a tiledb_ctx" = is(ctx, "tiledb_ctx"), + "domain argument must be a tiledb::Domain" = !missing(domain) && is(domain, "tiledb_domain"), + "cell_order argument must be a scalar string" = is.scalar(cell_order, "character"), + "tile_order argument must be a scalar string" = is.scalar(tile_order, "character"), + "coords_filter_list must be a filter list" = is.null(coords_filter_list) || is(coords_filter_list, "tiledb_filter_list"), + "offsets_filter_list must be a filter_list" = is.null(offsets_filter_list) || is(offsets_filter_list, "tiledb_filter_list"), + "validity_filter_list must be a_filter_list" = is.null(validity_filter_list) || is(validity_filter_list, "tiledb_filter_list"), + "'sparse' must be TRUE or FALSE" = is.logical(sparse), + "'allows_dups' must be TRUE or FALSE" = is.logical(allows_dups), + "'allows_dups' requires 'sparse' TRUE" = !allows_dups || sparse + ) + # if (allows_dups && !sparse) stop("'allows_dups' requires 'sparse' TRUE") + + attr_ptr_list <- if (is.list(attrs)) lapply(attrs, function(obj) slot(obj, "ptr")) else list() + coords_filter_list_ptr <- if (!is.null(coords_filter_list)) coords_filter_list@ptr else NULL + offsets_filter_list_ptr <- if (!is.null(offsets_filter_list)) offsets_filter_list@ptr else NULL + validity_filter_list_ptr <- if (!is.null(validity_filter_list)) validity_filter_list@ptr else NULL + + ptr <- libtiledb_array_schema( + ctx@ptr, domain@ptr, attr_ptr_list, cell_order, tile_order, + coords_filter_list_ptr, offsets_filter_list_ptr, + validity_filter_list_ptr, sparse, enumerations + ) + libtiledb_array_schema_set_capacity(ptr, capacity) + if (allows_dups) libtiledb_array_schema_set_allows_dups(ptr, TRUE) + invisible(new("tiledb_array_schema", ptr = ptr)) } tiledb_array_schema.from_array <- function(x, ctx = tiledb_get_context()) { - stopifnot(`The 'ctx' argument must be a tiledb_ctx object` = is(ctx, "tiledb_ctx"), - `The 'x' argument must be a valid array object` = !missing(x) && is.array(x)) + stopifnot( + `The 'ctx' argument must be a tiledb_ctx object` = is(ctx, "tiledb_ctx"), + `The 'x' argument must be a valid array object` = !missing(x) && is.array(x) + ) xdim <- dim(x) dims <- lapply(seq_len(xdim), function(i) { tiledb_dim(c(1L, xdim[i]), type = "INT32", ctx) }) dom <- tiledb_domain(dims, ctx) - #TODO: better datatype checking + # TODO: better datatype checking if (is.double(x)) { typestr <- "FLOAT64" } else if (is.integer(x)) { @@ -136,33 +157,36 @@ tiledb_array_schema.from_array <- function(x, ctx = tiledb_get_context()) { #' @param object An array_schema object #' @export setMethod("raw_dump", - signature(object = "tiledb_array_schema"), - definition = function(object) libtiledb_array_schema_dump(object@ptr)) + signature(object = "tiledb_array_schema"), + definition = function(object) libtiledb_array_schema_dump(object@ptr) +) #' Prints an array schema object #' #' @param object An array_schema object #' @export setMethod("show", signature(object = "tiledb_array_schema"), - definition = function(object) { + definition = function(object) { fl <- filter_list(object) nfc <- nfilters(fl$coords) nfo <- nfilters(fl$offsets) nfv <- nfilters(fl$validity) cat("tiledb_array_schema(\n domain=", .as_text_domain(domain(object)), ",\n", - " attrs=c(\n ", paste(sapply(attrs(object), .as_text_attribute, arrptr=object@arrptr), collapse=",\n "), "\n ),\n", - " cell_order=\"", cell_order(object), "\", ", - "tile_order=\"", tile_order(object), "\", ", - "capacity=", capacity(object), ", ", - "sparse=",if (is.sparse(object)) "TRUE" else "FALSE", ", ", - "allows_dups=", if (is.sparse(object)) allows_dups(object) else FALSE, - if (nfc + nfo + nfv > 0) ",\n" else "\n", - sep="") - if (nfc > 0) cat(" coords_filter_list=", .as_text_filter_list(fl$coords), if (nfo + nfv > 0) "," else "", "\n", sep="") - if (nfo > 0) cat(" offsets_filter_list=", .as_text_filter_list(fl$offsets), if (nfv > 0) ",\n" else "", sep="") - if (nfv > 0) cat(" validity_filter_list=", .as_text_filter_list(fl$validity), "\n", sep="") - cat(")\n", sep="") -}) + " attrs=c(\n ", paste(sapply(attrs(object), .as_text_attribute, arrptr = object@arrptr), collapse = ",\n "), "\n ),\n", + " cell_order=\"", cell_order(object), "\", ", + "tile_order=\"", tile_order(object), "\", ", + "capacity=", capacity(object), ", ", + "sparse=", if (is.sparse(object)) "TRUE" else "FALSE", ", ", + "allows_dups=", if (is.sparse(object)) allows_dups(object) else FALSE, + if (nfc + nfo + nfv > 0) ",\n" else "\n", + sep = "" + ) + if (nfc > 0) cat(" coords_filter_list=", .as_text_filter_list(fl$coords), if (nfo + nfv > 0) "," else "", "\n", sep = "") + if (nfo > 0) cat(" offsets_filter_list=", .as_text_filter_list(fl$offsets), if (nfv > 0) ",\n" else "", sep = "") + if (nfv > 0) cat(" validity_filter_list=", .as_text_filter_list(fl$validity), "\n", sep = "") + cat(")\n", sep = "") + } +) #' @rdname generics #' @export @@ -172,17 +196,21 @@ setGeneric("domain", function(object, ...) standardGeneric("domain")) #' #' @param object tiledb_array_schema #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' dom <- tiledb_domain(dims = c(tiledb_dim("d1", c(1L, 10L), type = "INT32"))) #' sch <- tiledb_array_schema(dom, attrs = c(tiledb_attr("a1", type = "INT32"))) #' domain(sch) #' #' @export -setMethod("domain", "tiledb_array_schema", - function(object) { - ptr <- libtiledb_array_schema_get_domain(object@ptr) - tiledb_domain.from_ptr(ptr) - }) +setMethod( + "domain", "tiledb_array_schema", + function(object) { + ptr <- libtiledb_array_schema_get_domain(object@ptr) + tiledb_domain.from_ptr(ptr) + } +) #' @rdname generics #' @export @@ -193,17 +221,23 @@ setGeneric("dimensions", function(object, ...) standardGeneric("dimensions")) #' @param object tiledb_array_schema #' @return a list of tiledb_dim objects #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} -#' dom <- tiledb_domain(dims = c(tiledb_dim("d1", c(1L, 100L), type = "INT32"), -#' tiledb_dim("d2", c(1L, 50L), type = "INT32"))) +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } +#' dom <- tiledb_domain(dims = c( +#' tiledb_dim("d1", c(1L, 100L), type = "INT32"), +#' tiledb_dim("d2", c(1L, 50L), type = "INT32") +#' )) #' sch <- tiledb_array_schema(dom, attrs = c(tiledb_attr("a1", type = "INT32"))) #' dimensions(dom) #' #' lapply(dimensions(dom), name) #' #' @export -setMethod("dimensions", "tiledb_array_schema", - function(object) dimensions(domain(object))) +setMethod( + "dimensions", "tiledb_array_schema", + function(object) dimensions(domain(object)) +) #' @rdname generics #' @export @@ -216,25 +250,31 @@ setGeneric("attrs", function(object, idx, ...) standardGeneric("attrs")) #' @param ... Extra parameter for method signature, currently unused. #' @return a list of tiledb_attr objects #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' dom <- tiledb_domain(dims = c(tiledb_dim("d1", c(1L, 10L), type = "INT32"))) -#' sch <- tiledb_array_schema(dom, attrs = c(tiledb_attr("a1", type = "INT32"), -#' tiledb_attr("a2", type = "FLOAT64"))) +#' sch <- tiledb_array_schema(dom, attrs = c( +#' tiledb_attr("a1", type = "INT32"), +#' tiledb_attr("a2", type = "FLOAT64") +#' )) #' attrs(sch) #' #' lapply(attrs(sch), datatype) #' #' @export -setMethod("attrs", signature("tiledb_array_schema"), - function (object, ...) { - attr_ptrs <- libtiledb_array_schema_attributes(object@ptr) - attrs <- lapply(attr_ptrs, function(ptr) tiledb_attr.from_ptr(ptr)) - names(attrs) <- vapply(attrs, function(attr) { - n <- tiledb::name(attr) - return(ifelse(n == "__attr", "", n)) - }, character(1)) - return(attrs) - }) +setMethod( + "attrs", signature("tiledb_array_schema"), + function(object, ...) { + attr_ptrs <- libtiledb_array_schema_attributes(object@ptr) + attrs <- lapply(attr_ptrs, function(ptr) tiledb_attr.from_ptr(ptr)) + names(attrs) <- vapply(attrs, function(attr) { + n <- tiledb::name(attr) + return(ifelse(n == "__attr", "", n)) + }, character(1)) + return(attrs) + } +) #' Returns a `tiledb_attr` object associated with the `tiledb_array_schema` with a given name. #' @@ -243,18 +283,24 @@ setMethod("attrs", signature("tiledb_array_schema"), #' @param ... Extra parameter for method signature, currently unused. #' @return a `tiledb_attr` object #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' dom <- tiledb_domain(dims = c(tiledb_dim("d1", c(1L, 10L), type = "INT32"))) -#' sch <- tiledb_array_schema(dom, attrs = c(tiledb_attr("a1", type = "INT32"), -#' tiledb_attr("a2", type = "FLOAT64"))) +#' sch <- tiledb_array_schema(dom, attrs = c( +#' tiledb_attr("a1", type = "INT32"), +#' tiledb_attr("a2", type = "FLOAT64") +#' )) #' attrs(sch, "a2") #' #' @export -setMethod("attrs", signature("tiledb_array_schema", "character"), - function(object, idx, ...) { - attrs <- tiledb::attrs(object) - return(attrs[[idx]]) - }) +setMethod( + "attrs", signature("tiledb_array_schema", "character"), + function(object, idx, ...) { + attrs <- tiledb::attrs(object) + return(attrs[[idx]]) + } +) #' Returns a `tiledb_attr` object associated with the `tiledb_array_schema` with a given index #' @@ -265,18 +311,24 @@ setMethod("attrs", signature("tiledb_array_schema", "character"), #' @param ... Extra parameter for method signature, currently unused. #' @return a `tiledb_attr` object #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' dom <- tiledb_domain(dims = c(tiledb_dim("d1", c(1L, 10L), type = "INT32"))) -#' sch <- tiledb_array_schema(dom, attrs = c(tiledb_attr("a1", type = "INT32"), -#' tiledb_attr("a2", type = "FLOAT64"))) +#' sch <- tiledb_array_schema(dom, attrs = c( +#' tiledb_attr("a1", type = "INT32"), +#' tiledb_attr("a2", type = "FLOAT64") +#' )) #' attrs(sch, 2) #' #' @export -setMethod("attrs", signature("tiledb_array_schema", "numeric"), - function(object, idx, ...) { - attrs <- tiledb::attrs(object) - return(attrs[[idx]]) - }) +setMethod( + "attrs", signature("tiledb_array_schema", "numeric"), + function(object, idx, ...) { + attrs <- tiledb::attrs(object) + return(attrs[[idx]]) + } +) #' @rdname generics #' @export @@ -285,10 +337,12 @@ setGeneric("cell_order", function(object, ...) standardGeneric("cell_order")) #' Returns the cell layout string associated with the `tiledb_array_schema` #' @param object tiledb object #' @export -setMethod("cell_order", "tiledb_array_schema", - function(object) { - libtiledb_array_schema_get_cell_order(object@ptr) - }) +setMethod( + "cell_order", "tiledb_array_schema", + function(object) { + libtiledb_array_schema_get_cell_order(object@ptr) + } +) #' @rdname generics #' @export @@ -297,18 +351,20 @@ setGeneric("tile_order", function(object, ...) standardGeneric("tile_order")) #' Returns the tile layout string associated with the `tiledb_array_schema` #' @param object tiledb object #' @export -setMethod("tile_order", "tiledb_array_schema", - function(object) { - libtiledb_array_schema_get_tile_order(object@ptr) - }) +setMethod( + "tile_order", "tiledb_array_schema", + function(object) { + libtiledb_array_schema_get_tile_order(object@ptr) + } +) # ' @ export -#tiledb_filter_list.tiledb_array_schema <- function(object) { +# tiledb_filter_list.tiledb_array_schema <- function(object) { # coords_ptr <- libtiledb_array_schema_get_coords_filter_list(object@ptr) # offsets_ptr <- libtiledb_array_schema_offsets_filter_list(object@ptr) # return(c(coords = tiledb_filter_list.from_ptr(coords_ptr), # offsets = tiledb_filter_list.from_ptr(offsets_ptr))) -#} +# } #' @rdname generics #' @export @@ -328,9 +384,11 @@ setMethod("filter_list", "tiledb_array_schema", function(object) { coords_ptr <- libtiledb_array_schema_get_coords_filter_list(object@ptr) offsets_ptr <- libtiledb_array_schema_get_offsets_filter_list(object@ptr) validity_ptr <- libtiledb_array_schema_get_validity_filter_list(object@ptr) - return(c(coords = tiledb_filter_list.from_ptr(coords_ptr), - offsets = tiledb_filter_list.from_ptr(offsets_ptr), - validity = tiledb_filter_list.from_ptr(validity_ptr))) + return(c( + coords = tiledb_filter_list.from_ptr(coords_ptr), + offsets = tiledb_filter_list.from_ptr(offsets_ptr), + validity = tiledb_filter_list.from_ptr(validity_ptr) + )) }) # ' Set the Filter List for a TileDB Schema @@ -339,10 +397,10 @@ setMethod("filter_list", "tiledb_array_schema", function(object) { # ' @param value A TileDB Filter List # ' @return The modified Array Schema object # ' @ export -#setReplaceMethod("filter_list", "tiledb_array_schema", function(x, value) { +# setReplaceMethod("filter_list", "tiledb_array_schema", function(x, value) { # x@ptr <- libtiledb_array_schema_set_coords_filter_list(x@ptr, value@ptr) # x -#}) +# }) ## -- need to provide setter for offsets and coords #' Set a Filter List for Coordinate of a TileDB Schema @@ -352,8 +410,10 @@ setMethod("filter_list", "tiledb_array_schema", function(object) { #' @return The modified Array Schema object #' @export tiledb_array_schema_set_coords_filter_list <- function(sch, fl) { - stopifnot(`The 'sch' argument must be a tiledb_array_schema object` = is(sch, "tiledb_array_schema"), - `The 'fl' argument must be a tiledb_filter_list object` = is(fl, "tiledb_filter_list")) + stopifnot( + `The 'sch' argument must be a tiledb_array_schema object` = is(sch, "tiledb_array_schema"), + `The 'fl' argument must be a tiledb_filter_list object` = is(fl, "tiledb_filter_list") + ) sch@ptr <- libtiledb_array_schema_set_coords_filter_list(sch@ptr, fl@ptr) sch } @@ -365,8 +425,10 @@ tiledb_array_schema_set_coords_filter_list <- function(sch, fl) { #' @return The modified Array Schema object #' @export tiledb_array_schema_set_offsets_filter_list <- function(sch, fl) { - stopifnot(`The 'sch' argument must be a tiledb_array_schema object` = is(sch, "tiledb_array_schema"), - `The 'fl' argument must be a tiledb_filter_list object` = is(fl, "tiledb_filter_list")) + stopifnot( + `The 'sch' argument must be a tiledb_array_schema object` = is(sch, "tiledb_array_schema"), + `The 'fl' argument must be a tiledb_filter_list object` = is(fl, "tiledb_filter_list") + ) sch@ptr <- libtiledb_array_schema_set_offsets_filter_list(sch@ptr, fl@ptr) sch } @@ -378,8 +440,10 @@ tiledb_array_schema_set_offsets_filter_list <- function(sch, fl) { #' @return The modified Array Schema object #' @export tiledb_array_schema_set_validity_filter_list <- function(sch, fl) { - stopifnot(`The 'sch' argument must be a tiledb_array_schema object` = is(sch, "tiledb_array_schema"), - `The 'fl' argument must be a tiledb_filter_list object` = is(fl, "tiledb_filter_list")) + stopifnot( + `The 'sch' argument must be a tiledb_array_schema object` = is(sch, "tiledb_array_schema"), + `The 'fl' argument must be a tiledb_filter_list object` = is(fl, "tiledb_filter_list") + ) sch@ptr <- libtiledb_array_schema_set_validity_filter_list(sch@ptr, fl@ptr) sch } @@ -393,10 +457,12 @@ setGeneric("is.sparse", function(object, ...) standardGeneric("is.sparse")) #' @param object tiledb_array_schema #' @return TRUE if tiledb_array_schema is sparse #' @export -setMethod("is.sparse", "tiledb_array_schema", - function(object) { - libtiledb_array_schema_sparse(object@ptr) - }) +setMethod( + "is.sparse", "tiledb_array_schema", + function(object) { + libtiledb_array_schema_sparse(object@ptr) + } +) #' @rdname generics #' @export @@ -407,18 +473,24 @@ setGeneric("tiledb_ndim", function(object, ...) standardGeneric("tiledb_ndim")) #' @param object tiledb_array_schema #' @return integer number of dimensions #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' dom <- tiledb_domain(dims = c(tiledb_dim("d1", c(1L, 10L), type = "INT32"))) -#' sch <- tiledb_array_schema(dom, attrs = c(tiledb_attr("a1", type = "INT32"), -#' tiledb_attr("a2", type = "FLOAT64"))) +#' sch <- tiledb_array_schema(dom, attrs = c( +#' tiledb_attr("a1", type = "INT32"), +#' tiledb_attr("a2", type = "FLOAT64") +#' )) #' tiledb_ndim(sch) #' #' @export -setMethod("tiledb_ndim", "tiledb_array_schema", - function(object) { - dom <- tiledb::domain(object) - return(tiledb_ndim(dom)) - }) +setMethod( + "tiledb_ndim", "tiledb_array_schema", + function(object) { + dom <- tiledb::domain(object) + return(tiledb_ndim(dom)) + } +) #' Retrieve the dimension (domain extent) of the domain #' @@ -427,10 +499,14 @@ setMethod("tiledb_ndim", "tiledb_array_schema", #' @param x tiledb_array_schema #' @return a dimension vector #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' dom <- tiledb_domain(dims = c(tiledb_dim("d1", c(1L, 10L), type = "INT32"))) -#' sch <- tiledb_array_schema(dom, attrs = c(tiledb_attr("a1", type = "INT32"), -#' tiledb_attr("a2", type = "FLOAT64"))) +#' sch <- tiledb_array_schema(dom, attrs = c( +#' tiledb_attr("a1", type = "INT32"), +#' tiledb_attr("a2", type = "FLOAT64") +#' )) #' dim(sch) #' #' @export @@ -474,10 +550,14 @@ setGeneric("allows_dups<-", function(x, value) standardGeneric("allows_dups<-")) #' @rdname tiledb_array_schema_set_allows_dups #' @export -setMethod("allows_dups<-", signature = "tiledb_array_schema", function(x, value) { - libtiledb_array_schema_set_allows_dups(x@ptr, value) - x -}) +setMethod( + "allows_dups<-", + signature = "tiledb_array_schema", + definition = function(x, value) { + libtiledb_array_schema_set_allows_dups(x@ptr, value) + x + } +) #' Sets toggle whether the array schema allows duplicate values or not. #' This is only valid for sparse arrays. @@ -487,8 +567,10 @@ setMethod("allows_dups<-", signature = "tiledb_array_schema", function(x, value) #' @return the tiledb_array_schema object #' @export tiledb_array_schema_set_allows_dups <- function(x, value) { - stopifnot(`The 'x' argument must be a tiledb_array_schema object` = is(x, "tiledb_array_schema"), - `The 'value' argument must be a boolean` = is.logical(value)) + stopifnot( + `The 'x' argument must be a tiledb_array_schema object` = is(x, "tiledb_array_schema"), + `The 'value' argument must be a boolean` = is.logical(value) + ) libtiledb_array_schema_set_allows_dups(x@ptr, value) } @@ -553,12 +635,14 @@ tiledb_schema_get_dim_attr_status <- function(sch) { ##' @return An integer vector where each element corresponds to a schema entry, ##' and a value of one signals dimension and a value of two an attribute. tiledb_schema_get_enumeration_status <- function(sch) { - stopifnot("The 'sch' argument must be a schema" = is(sch, "tiledb_array_schema")) - dom <- tiledb::domain(sch) - dims <- tiledb::dimensions(dom) - attrs <- tiledb::attrs(sch) - return(c(rep(FALSE, length(dims)), - sapply(attrs, tiledb_attribute_has_enumeration))) + stopifnot("The 'sch' argument must be a schema" = is(sch, "tiledb_array_schema")) + dom <- tiledb::domain(sch) + dims <- tiledb::dimensions(dom) + attrs <- tiledb::attrs(sch) + return(c( + rep(FALSE, length(dims)), + sapply(attrs, tiledb_attribute_has_enumeration) + )) } @@ -580,10 +664,14 @@ setMethod("capacity", signature = "tiledb_array_schema", function(object) { #' @rdname tiledb_array_schema_set_capacity #' @export -setReplaceMethod("capacity", signature = "tiledb_array_schema", function(x, value) { - libtiledb_array_schema_set_capacity(x@ptr, value) - x -}) +setReplaceMethod( + "capacity", + signature = "tiledb_array_schema", + function(x, value) { + libtiledb_array_schema_set_capacity(x@ptr, value) + x + } +) #' Retrieve schema capacity (for sparse fragments) #' @@ -604,8 +692,10 @@ tiledb_array_schema_get_capacity <- function(object) { #' @return The modified \code{array_schema} object #' @export tiledb_array_schema_set_capacity <- function(x, value) { - stopifnot(`The first argument must be a tiledb_array_schema object` = is(x, "tiledb_array_schema"), - `The second argumebt must be a int or numeric value` = is.numeric(value)) + stopifnot( + `The first argument must be a tiledb_array_schema object` = is(x, "tiledb_array_schema"), + `The second argumebt must be a int or numeric value` = is.numeric(value) + ) libtiledb_array_schema_set_capacity(x@ptr, value) x } @@ -621,9 +711,13 @@ setGeneric("schema_check", function(object) standardGeneric("schema_check")) #' @rdname tiledb_array_schema_check #' @export -setMethod("schema_check", signature = "tiledb_array_schema", function(object) { - libtiledb_array_schema_check(object@ptr) -}) +setMethod( + "schema_check", + signature = "tiledb_array_schema", + definition = function(object) { + libtiledb_array_schema_check(object@ptr) + } +) ## -- To be removed by May 2023 or later @@ -634,8 +728,8 @@ setGeneric("check", function(object) standardGeneric("check")) #' @rdname tiledb_array_schema_check #' @export setMethod("check", signature = "tiledb_array_schema", function(object) { - .Deprecated(msg="check() is deprecated, please use schema_check() instead.") - libtiledb_array_schema_check(object@ptr) + .Deprecated(msg = "check() is deprecated, please use schema_check() instead.") + libtiledb_array_schema_check(object@ptr) }) @@ -673,8 +767,10 @@ tiledb_array_schema_version <- function(object) { #' @return A boolean value indicating if the attribute exists in the schema #' @export has_attribute <- function(schema, attr) { - stopifnot(`The 'schema' argument must be an array schema` = is(schema, "tiledb_array_schema"), - `The 'attr' argument must be a character` = is.character(attr)) + stopifnot( + `The 'schema' argument must be an array schema` = is(schema, "tiledb_array_schema"), + `The 'attr' argument must be a character` = is.character(attr) + ) libtiledb_array_schema_has_attribute(schema@ptr, attr) } @@ -682,16 +778,16 @@ has_attribute <- function(schema, attr) { ## internal helper function .getFilterOption <- function(fltobj) { - flt <- tiledb_filter_type(fltobj) - if (flt %in% c("GZIP", "ZSTD", "LZ4", "BZIP2", "RLE")) { - paste0("COMPRESSION_LEVEL", "=", tiledb_filter_get_option(fltobj, "COMPRESSION_LEVEL")) - } else if (flt %in% "BIT_WIDTH_REDUCTION") { - paste0("BIT_WIDTH_MAX_WINDOW", "=", tiledb_filter_get_option(fltobj, "BIT_WIDTH_MAX_WINDOW")) - } else if (flt %in% "POSITIVE_DELTA") { - paste0("POSITIVE_DELTA_MAX_WINDOW", "=", tiledb_filter_get_option(fltobj, "POSITIVE_DELTA_MAX_WINDOW")) - } else { - paste0("NA") - } + flt <- tiledb_filter_type(fltobj) + if (flt %in% c("GZIP", "ZSTD", "LZ4", "BZIP2", "RLE")) { + paste0("COMPRESSION_LEVEL", "=", tiledb_filter_get_option(fltobj, "COMPRESSION_LEVEL")) + } else if (flt %in% "BIT_WIDTH_REDUCTION") { + paste0("BIT_WIDTH_MAX_WINDOW", "=", tiledb_filter_get_option(fltobj, "BIT_WIDTH_MAX_WINDOW")) + } else if (flt %in% "POSITIVE_DELTA") { + paste0("POSITIVE_DELTA_MAX_WINDOW", "=", tiledb_filter_get_option(fltobj, "POSITIVE_DELTA_MAX_WINDOW")) + } else { + paste0("NA") + } } #' Succinctly describe a TileDB array schema @@ -702,165 +798,198 @@ has_attribute <- function(schema, attr) { #' @return A list containing two data frames, one describing the overall array as well as one #' with descriptions about dimensions and attributes in the schema tiledb_schema_object <- function(array) { - stopifnot(`Argument must be a 'tiledb_array'` = is(array, "tiledb_array")) - - ctx <- array@ctx - uri <- array@uri - sch <- schema(array) - dom <- domain(sch) - sparse <- is.sparse(sch) - cell_order <- cell_order(sch) - tile_order <- tile_order(sch) - capacity <- tiledb_array_schema_get_capacity(sch) - dupes <- if (sparse) allows_dups(sch) else FALSE - filterlist <- filter_list(sch) - n_coord <- nfilters(filterlist$coords) - coords <- sapply(seq_len(n_coord), function(i) tiledb_filter_type(filterlist$coords[i-1])) - coordopts <- sapply(seq_len(n_coord), function(i) .getFilterOption(filterlist$coords[i-1])) - n_offsets <- nfilters(filterlist$offsets) - offsets <- sapply(seq_len(n_offsets), function(i) tiledb_filter_type(filterlist$offsets[i-1])) - offsetopts <- sapply(seq_len(n_offsets), function(i) .getFilterOption(filterlist$offsets[i-1])) - n_validity <- nfilters(filterlist$validity) - validity <- sapply(seq_len(n_validity), function(i) tiledb_filter_type(filterlist$validity[i-1])) - validityopts <- sapply(seq_len(n_validity), function(i) .getFilterOption(filterlist$validity[i-1])) - - arrdesc <- data.frame(uri = uri, - type = if (sparse) "sparse" else "dense", - cell_order = cell_order, - tile_order = tile_order, - capacity = capacity, - allow_dupes = dupes, - coord_filters = paste0(coords, collapse=","), - coord_options = paste0(coordopts, collapse=","), - offset_filters = paste0(offsets, collapse=","), - offset_options = paste0(offsetopts, collapse=","), - validity_filters = paste0(validity, collapse=","), - validity_options = paste0(validityopts, collapse=",") - ) - - dims <- dimensions(dom) - dimnames <- sapply(dims, name) - dimtypes <- sapply(dims, datatype) - dimvarnum <- sapply(dims, cell_val_num) - dimnullable <- sapply(dims, function(d) FALSE) - dimdomains <- mapply(function(d, dtype) if (is.na(cell_val_num(d))) "NULL,NULL" - else paste0(paste0(domain(d), if (grepl("INT", dtype)) "L" else ""), collapse=","), - dims, dimtypes) - dimextent <- mapply(function(d, dtype) if (is.na(cell_val_num(d))) "NULL" else paste0(dim(d), if (grepl("INT", dtype)) "L" else ""), - dims, dimtypes) - dimnfilt <- sapply(dims, function(d) nfilters(filter_list(d))) - - dimdesc <- data.frame(names = dimnames, - datatype = dimtypes, - nullable = dimnullable, - varnum = dimvarnum, - domain = dimdomains, - extent = dimextent, - nfilters = dimnfilt) - - attrs <- attrs(sch) - attrnames <- sapply(attrs, name) - attrtypes <- sapply(attrs, datatype) - attrvarnum <- sapply(attrs, cell_val_num) - attrnullable <- sapply(attrs, tiledb_attribute_get_nullable) - attrnfilt <- sapply(attrs, function(a) nfilters(filter_list(a))) - attrfltrs <- unname(sapply(attrs, function(a) { - fltlst <- filter_list(a) - if (nfilters(fltlst) == 0) "" - else sapply(seq_len(nfilters(fltlst)), function(i) tiledb_filter_type(fltlst[i-1])) - })) - attrfltropts <- unname(sapply(attrs, function(a) { - fltlst <- filter_list(a) - if (nfilters(fltlst) == 0) "" - else sapply(seq_len(nfilters(fltlst)), function(i) .getFilterOption(fltlst[i-1])) - })) - attrfillvals <- sapply(attrs, function(a) if (tiledb_attribute_get_nullable(a)) "" - else format(tiledb_attribute_get_fill_value(a))) - - attrdesc <- data.frame(names = attrnames, - datatype = attrtypes, - nullable = attrnullable, - varnum = attrvarnum, - nfilters = attrnfilt, - filters = attrfltrs, - filtopts = attrfltropts, - fillvalue = attrfillvals) - - list(array=arrdesc, dom=dimdesc, attr=attrdesc) + stopifnot(`Argument must be a 'tiledb_array'` = is(array, "tiledb_array")) + + ctx <- array@ctx + uri <- array@uri + sch <- schema(array) + dom <- domain(sch) + sparse <- is.sparse(sch) + cell_order <- cell_order(sch) + tile_order <- tile_order(sch) + capacity <- tiledb_array_schema_get_capacity(sch) + dupes <- if (sparse) allows_dups(sch) else FALSE + filterlist <- filter_list(sch) + n_coord <- nfilters(filterlist$coords) + coords <- sapply(seq_len(n_coord), function(i) tiledb_filter_type(filterlist$coords[i - 1])) + coordopts <- sapply(seq_len(n_coord), function(i) .getFilterOption(filterlist$coords[i - 1])) + n_offsets <- nfilters(filterlist$offsets) + offsets <- sapply(seq_len(n_offsets), function(i) tiledb_filter_type(filterlist$offsets[i - 1])) + offsetopts <- sapply(seq_len(n_offsets), function(i) .getFilterOption(filterlist$offsets[i - 1])) + n_validity <- nfilters(filterlist$validity) + validity <- sapply(seq_len(n_validity), function(i) tiledb_filter_type(filterlist$validity[i - 1])) + validityopts <- sapply(seq_len(n_validity), function(i) .getFilterOption(filterlist$validity[i - 1])) + + arrdesc <- data.frame( + uri = uri, + type = if (sparse) "sparse" else "dense", + cell_order = cell_order, + tile_order = tile_order, + capacity = capacity, + allow_dupes = dupes, + coord_filters = paste0(coords, collapse = ","), + coord_options = paste0(coordopts, collapse = ","), + offset_filters = paste0(offsets, collapse = ","), + offset_options = paste0(offsetopts, collapse = ","), + validity_filters = paste0(validity, collapse = ","), + validity_options = paste0(validityopts, collapse = ",") + ) + + dims <- dimensions(dom) + dimnames <- sapply(dims, name) + dimtypes <- sapply(dims, datatype) + dimvarnum <- sapply(dims, cell_val_num) + dimnullable <- sapply(dims, function(d) FALSE) + dimdomains <- mapply( + function(d, dtype) { + if (is.na(cell_val_num(d))) { + "NULL,NULL" + } else { + paste0(paste0(domain(d), if (grepl("INT", dtype)) "L" else ""), collapse = ",") + } + }, + dims, dimtypes + ) + dimextent <- mapply( + function(d, dtype) if (is.na(cell_val_num(d))) "NULL" else paste0(dim(d), if (grepl("INT", dtype)) "L" else ""), + dims, dimtypes + ) + dimnfilt <- sapply(dims, function(d) nfilters(filter_list(d))) + + dimdesc <- data.frame( + names = dimnames, + datatype = dimtypes, + nullable = dimnullable, + varnum = dimvarnum, + domain = dimdomains, + extent = dimextent, + nfilters = dimnfilt + ) + + attrs <- attrs(sch) + attrnames <- sapply(attrs, name) + attrtypes <- sapply(attrs, datatype) + attrvarnum <- sapply(attrs, cell_val_num) + attrnullable <- sapply(attrs, tiledb_attribute_get_nullable) + attrnfilt <- sapply(attrs, function(a) nfilters(filter_list(a))) + attrfltrs <- unname(sapply(attrs, function(a) { + fltlst <- filter_list(a) + if (nfilters(fltlst) == 0) { + "" + } else { + sapply(seq_len(nfilters(fltlst)), function(i) tiledb_filter_type(fltlst[i - 1])) + } + })) + attrfltropts <- unname(sapply(attrs, function(a) { + fltlst <- filter_list(a) + if (nfilters(fltlst) == 0) { + "" + } else { + sapply(seq_len(nfilters(fltlst)), function(i) .getFilterOption(fltlst[i - 1])) + } + })) + attrfillvals <- sapply(attrs, function(a) { + if (tiledb_attribute_get_nullable(a)) { + "" + } else { + format(tiledb_attribute_get_fill_value(a)) + } + }) + + attrdesc <- data.frame( + names = attrnames, + datatype = attrtypes, + nullable = attrnullable, + varnum = attrvarnum, + nfilters = attrnfilt, + filters = attrfltrs, + filtopts = attrfltropts, + fillvalue = attrfillvals + ) + + list(array = arrdesc, dom = dimdesc, attr = attrdesc) } ## 'describe/create' hence dc. name is work in progress. not exported yet .describe_domain <- function(dom) { - cat("dims <- c(") - sapply(seq_len(nrow(dom)), function(i) { - d <- dom[i,,drop=TRUE] - cat(ifelse(i == 1, "", " "), - "tiledb_dim(name=\"", d$name, "\", ", - "domain=c(", d$domain, "), ", - "tile=", d$extent, ", ", - "type=\"", d$datatype, "\")", - ifelse(i < nrow(dom), ",", ")"), - "\n", - sep="") - }) - cat("dom <- tiledb_domain(dims=dims)\n") - invisible(NULL) + cat("dims <- c(") + sapply(seq_len(nrow(dom)), function(i) { + d <- dom[i, , drop = TRUE] + cat(ifelse(i == 1, "", " "), + "tiledb_dim(name=\"", d$name, "\", ", + "domain=c(", d$domain, "), ", + "tile=", d$extent, ", ", + "type=\"", d$datatype, "\")", + ifelse(i < nrow(dom), ",", ")"), + "\n", + sep = "" + ) + }) + cat("dom <- tiledb_domain(dims=dims)\n") + invisible(NULL) } -.show_filter_list <- function(filter, filter_options, prefix="") { - fltrs <- strsplit(filter, ",")[[1]] - opts <- strsplit(filter_options, ",")[[1]] - txt <- paste0(prefix, "tiledb_filter_list(c(") - for (i in seq_along(fltrs)) { - if (opts[i] == "NA") { - txt <- paste0(txt, "tiledb_filter(\"", fltrs[i], "\")") - } else { - option <- strsplit(opts[i], "=")[[1]] - txt <- paste0(txt, "tiledb_filter_set_option(tiledb_filter(\"", fltrs[i], - "\"),\"", option[1], "\",", option[2], ")") - } - txt <- paste0(txt, if (i != length(fltrs)) ", " else ")") +.show_filter_list <- function(filter, filter_options, prefix = "") { + fltrs <- strsplit(filter, ",")[[1]] + opts <- strsplit(filter_options, ",")[[1]] + txt <- paste0(prefix, "tiledb_filter_list(c(") + for (i in seq_along(fltrs)) { + if (opts[i] == "NA") { + txt <- paste0(txt, "tiledb_filter(\"", fltrs[i], "\")") + } else { + option <- strsplit(opts[i], "=")[[1]] + txt <- paste0( + txt, "tiledb_filter_set_option(tiledb_filter(\"", fltrs[i], + "\"),\"", option[1], "\",", option[2], ")" + ) } - txt <- paste0(txt, ")") - txt + txt <- paste0(txt, if (i != length(fltrs)) ", " else ")") + } + txt <- paste0(txt, ")") + txt } .describe_attrs <- function(attr) { - cat("attrs <- c(") - sapply(seq_len(nrow(attr)), function(i) { - a <- attr[i,,drop=TRUE] - cat(ifelse(i == 1, "", " "), - "tiledb_attr(name=\"", a$name, "\", ", - "type=\"", a$datatype, "\", ", - "ncells=", a$varnum, ", ", - "nullable=", a$nullable, ", ", - ifelse(a$filters != "", .show_filter_list(a$filters, a$filtopts), ""), - ")", - ifelse(i < nrow(attr), ",", ")"), - "\n", - sep="") - }) - invisible(NULL) + cat("attrs <- c(") + sapply(seq_len(nrow(attr)), function(i) { + a <- attr[i, , drop = TRUE] + cat(ifelse(i == 1, "", " "), + "tiledb_attr(name=\"", a$name, "\", ", + "type=\"", a$datatype, "\", ", + "ncells=", a$varnum, ", ", + "nullable=", a$nullable, ", ", + ifelse(a$filters != "", .show_filter_list(a$filters, a$filtopts), ""), + ")", + ifelse(i < nrow(attr), ",", ")"), + "\n", + sep = "" + ) + }) + invisible(NULL) } .describe_schema <- function(sch) { - cat("sch <- tiledb_array_schema(domain=dom, attrs=attrs, ", - "cell_order=\"", sch$cell_order, "\", ", - "tile_order=\"", sch$tile_order, "\", ", - "sparse=", if (sch$type=="sparse") "TRUE" else "FALSE", ", ", - "capacity=", sch$capacity, ", ", - "allows_dups=", sch$allow_dupes, ", ", - ifelse(sch$coord_filters != "", - .show_filter_list(sch$coord_filters, sch$coord_options, "\n\t\t\t coords_filter_list="), - "coord_filters=NULL"), ", ", - ifelse(sch$offset_filters != "", - .show_filter_list(sch$offset_filters, sch$offset_options, "\n\t\t\t offsets_filter_list="), - "offset_filters=NULL"), ", ", - ifelse(sch$validity_filters != "", - .show_filter_list(sch$validity_filters, sch$validity_options, "\n\t\t\t validity_filter_list="), - "validity_filters=NULL"), ")\n", - "tiledb_array_create(uri=tempfile(), schema=sch)) # or assign your URI here\n", - sep="") + cat("sch <- tiledb_array_schema(domain=dom, attrs=attrs, ", + "cell_order=\"", sch$cell_order, "\", ", + "tile_order=\"", sch$tile_order, "\", ", + "sparse=", if (sch$type == "sparse") "TRUE" else "FALSE", ", ", + "capacity=", sch$capacity, ", ", + "allows_dups=", sch$allow_dupes, ", ", + ifelse(sch$coord_filters != "", + .show_filter_list(sch$coord_filters, sch$coord_options, "\n\t\t\t coords_filter_list="), + "coord_filters=NULL" + ), ", ", + ifelse(sch$offset_filters != "", + .show_filter_list(sch$offset_filters, sch$offset_options, "\n\t\t\t offsets_filter_list="), + "offset_filters=NULL" + ), ", ", + ifelse(sch$validity_filters != "", + .show_filter_list(sch$validity_filters, sch$validity_options, "\n\t\t\t validity_filter_list="), + "validity_filters=NULL" + ), ")\n", + "tiledb_array_create(uri=tempfile(), schema=sch)) # or assign your URI here\n", + sep = "" + ) } #' Describe a TileDB array schema via code to create it @@ -872,11 +1001,11 @@ tiledb_schema_object <- function(array) { #' @return Nothing is returned as the function is invoked for the side effect #' of printing the schema via a sequence of R instructions to re-create it. describe <- function(arr) { - stopifnot(`Argument must be a 'tiledb_array' object` = is(arr, "tiledb_array")) - obj <- tiledb_schema_object(arr) - .describe_domain(obj$dom) - .describe_attrs(obj$attr) - .describe_schema(obj$array) + stopifnot(`Argument must be a 'tiledb_array' object` = is(arr, "tiledb_array")) + obj <- tiledb_schema_object(arr) + .describe_domain(obj$dom) + .describe_attrs(obj$attr) + .describe_schema(obj$array) } #' Add an empty Enumeration to a Schema @@ -891,20 +1020,30 @@ describe <- function(arr) { #' or \code{ordered} (when \code{TRUE}) #' @param ctx Optional tiledb_ctx object #' @export -tiledb_array_schema_set_enumeration_empty <- function(schema, attr, enum_name, - type_str = "ASCII", cell_val_num = NA_integer_, - ordered = FALSE, ctx = tiledb_get_context()) { - stopifnot("Argument 'schema' must be a 'tiledb_array_schema'" = is(schema, "tiledb_array_schema"), - "Argument 'attr' must be a 'tiledb_attribute'" = is(attr, "tiledb_attr"), - "Argument 'enum_name' must be character" = is.character(enum_name), - "Argument 'type_str' must be character" = is.character(type_str), - "Argument 'cell_val_num' must be integer" = is.integer(cell_val_num), - "Argument 'ordered' must be logical" = is.logical(ordered), - "Argument 'ctx' must be a 'tiledb_ctx'" = is(ctx, "tiledb_ctx")) - schema@ptr <- libtiledb_array_schema_set_enumeration_empty(ctx@ptr, schema@ptr, attr@ptr, - enum_name, type_str, cell_val_num, - ordered) - schema +tiledb_array_schema_set_enumeration_empty <- function( + schema, + attr, + enum_name, + type_str = "ASCII", + cell_val_num = NA_integer_, + ordered = FALSE, + ctx = tiledb_get_context() +) { + stopifnot( + "Argument 'schema' must be a 'tiledb_array_schema'" = is(schema, "tiledb_array_schema"), + "Argument 'attr' must be a 'tiledb_attribute'" = is(attr, "tiledb_attr"), + "Argument 'enum_name' must be character" = is.character(enum_name), + "Argument 'type_str' must be character" = is.character(type_str), + "Argument 'cell_val_num' must be integer" = is.integer(cell_val_num), + "Argument 'ordered' must be logical" = is.logical(ordered), + "Argument 'ctx' must be a 'tiledb_ctx'" = is(ctx, "tiledb_ctx") + ) + schema@ptr <- libtiledb_array_schema_set_enumeration_empty( + ctx@ptr, schema@ptr, attr@ptr, + enum_name, type_str, cell_val_num, + ordered + ) + schema } #' Get the Current Domain of an Array Schema @@ -914,11 +1053,16 @@ tiledb_array_schema_set_enumeration_empty <- function(schema, attr, enum_name, #' @param ctx Optional tiledb_ctx object #' @return A 'CurrendDomain' object #' @export -tiledb_array_schema_get_current_domain <- function(schema, ctx = tiledb_get_context()) { - stopifnot("Argument 'schema' must be a 'tiledb_array_schema'" = is(schema, "tiledb_array_schema"), - "Argument 'ctx' must be a 'tiledb_ctx'" = is(ctx, "tiledb_ctx")) - cdptr <- libtiledb_array_schema_get_current_domain(ctx@ptr, schema@ptr) - new("tiledb_current_domain", ptr=cdptr) +tiledb_array_schema_get_current_domain <- function( + schema, + ctx = tiledb_get_context() +) { + stopifnot( + "Argument 'schema' must be a 'tiledb_array_schema'" = is(schema, "tiledb_array_schema"), + "Argument 'ctx' must be a 'tiledb_ctx'" = is(ctx, "tiledb_ctx") + ) + cdptr <- libtiledb_array_schema_get_current_domain(ctx@ptr, schema@ptr) + new("tiledb_current_domain", ptr = cdptr) } #' Set a Current Domain of an Array Schema @@ -928,10 +1072,16 @@ tiledb_array_schema_get_current_domain <- function(schema, ctx = tiledb_get_cont #' @param ctx Optional tiledb_ctx object #' @return Nothing is returned from this function (but an error, should it occur is reported) #' @export -tiledb_array_schema_set_current_domain <- function(schema, cd, ctx = tiledb_get_context()) { - stopifnot("Argument 'schema' must be a 'tiledb_array_schema'" = is(schema, "tiledb_array_schema"), - "Argument 'cd' must be a 'tiledb_current_domain'" = is(cd, "tiledb_current_domain"), - "Argument 'ctx' must be a 'tiledb_ctx'" = is(ctx, "tiledb_ctx")) - libtiledb_array_schema_set_current_domain(ctx@ptr, schema@ptr, cd@ptr) - invisible(NULL) +tiledb_array_schema_set_current_domain <- function( + schema, + cd, + ctx = tiledb_get_context() +) { + stopifnot( + "Argument 'schema' must be a 'tiledb_array_schema'" = is(schema, "tiledb_array_schema"), + "Argument 'cd' must be a 'tiledb_current_domain'" = is(cd, "tiledb_current_domain"), + "Argument 'ctx' must be a 'tiledb_ctx'" = is(ctx, "tiledb_ctx") + ) + libtiledb_array_schema_set_current_domain(ctx@ptr, schema@ptr, cd@ptr) + invisible(NULL) } diff --git a/R/ArraySchemaEvolution.R b/R/ArraySchemaEvolution.R index 3fefabd1aa..28afc1ab23 100644 --- a/R/ArraySchemaEvolution.R +++ b/R/ArraySchemaEvolution.R @@ -25,7 +25,8 @@ #' @slot ptr An external pointer to the underlying implementation #' @exportClass tiledb_array_schema_evolution setClass("tiledb_array_schema_evolution", - slots = list(ptr = "externalptr")) + slots = list(ptr = "externalptr") +) #' Creates a 'tiledb_array_schema_evolution' object #' @@ -34,10 +35,10 @@ setClass("tiledb_array_schema_evolution", #' @return A 'array_schema_evolution' object #' @export tiledb_array_schema_evolution <- function(ctx = tiledb_get_context()) { - stopifnot(`The 'ctx' argument must be a Context object` = is(ctx, "tiledb_ctx")) - ptr <- libtiledb_array_schema_evolution(ctx@ptr) - array_schema_evolution <- new("tiledb_array_schema_evolution", ptr = ptr) - invisible(array_schema_evolution) + stopifnot(`The 'ctx' argument must be a Context object` = is(ctx, "tiledb_ctx")) + ptr <- libtiledb_array_schema_evolution(ctx@ptr) + array_schema_evolution <- new("tiledb_array_schema_evolution", ptr = ptr) + invisible(array_schema_evolution) } #' Add an Attribute to a TileDB Array Schema Evolution object @@ -47,11 +48,13 @@ tiledb_array_schema_evolution <- function(ctx = tiledb_get_context()) { #' @return The modified 'array_schema_evolution' object, invisibly #' @export tiledb_array_schema_evolution_add_attribute <- function(object, attr) { - stopifnot(`The first argument must be a Array Schema Evolution object` = - is(object, "tiledb_array_schema_evolution"), - `The 'attr' argument must be an Attribute object` = is(attr, "tiledb_attr")) - object@ptr <- libtiledb_array_schema_evolution_add_attribute(object@ptr, attr@ptr) - invisible(object) + stopifnot( + `The first argument must be a Array Schema Evolution object` = + is(object, "tiledb_array_schema_evolution"), + `The 'attr' argument must be an Attribute object` = is(attr, "tiledb_attr") + ) + object@ptr <- libtiledb_array_schema_evolution_add_attribute(object@ptr, attr@ptr) + invisible(object) } #' Drop an attribute given by name from a TileDB Array Schema Evolution object @@ -61,11 +64,13 @@ tiledb_array_schema_evolution_add_attribute <- function(object, attr) { #' @return The modified 'array_schema_evolution' object, invisibly #' @export tiledb_array_schema_evolution_drop_attribute <- function(object, attrname) { - stopifnot(`The first argument must be a Array Schema Evolution object` = - is(object, "tiledb_array_schema_evolution"), - `The 'attrname' argument must be character variable` = is.character(attrname)) - object@ptr <- libtiledb_array_schema_evolution_drop_attribute(object@ptr, attrname) - invisible(object) + stopifnot( + `The first argument must be a Array Schema Evolution object` = + is(object, "tiledb_array_schema_evolution"), + `The 'attrname' argument must be character variable` = is.character(attrname) + ) + object@ptr <- libtiledb_array_schema_evolution_drop_attribute(object@ptr, attrname) + invisible(object) } #' Evolve an Array Schema @@ -75,11 +80,13 @@ tiledb_array_schema_evolution_drop_attribute <- function(object, attrname) { #' @return The modified 'array_schema_evolution' object, invisibly #' @export tiledb_array_schema_evolution_array_evolve <- function(object, uri) { - stopifnot(`The first argument must be a Array Schema Evolution object` = - is(object, "tiledb_array_schema_evolution"), - `The 'uri' argument must be character variable` = is.character(uri)) - object@ptr <- libtiledb_array_schema_evolution_array_evolve(object@ptr, uri) - invisible(object) + stopifnot( + `The first argument must be a Array Schema Evolution object` = + is(object, "tiledb_array_schema_evolution"), + `The 'uri' argument must be character variable` = is.character(uri) + ) + object@ptr <- libtiledb_array_schema_evolution_array_evolve(object@ptr, uri) + invisible(object) } #' Add an Enumeration to a TileDB Array Schema Evolution object @@ -92,18 +99,27 @@ tiledb_array_schema_evolution_array_evolve <- function(object, uri) { #' context object is retrieved #' @return The modified 'array_schema_evolution' object, invisibly #' @export -tiledb_array_schema_evolution_add_enumeration <- function(object, name, enums, ordered=FALSE, - ctx = tiledb_get_context()) { - stopifnot("The first argument must be an Array Schema Evolution object" = - is(object, "tiledb_array_schema_evolution"), - "The 'name' argument must be a scalar character object" = - is.character(name) && length(name) == 1, - "The 'enumlist' argument must be a character object" = is.character(enums), - "This function needs TileDB 2.17.0 or later" = tiledb_version(TRUE) >= "2.17.0", - "The 'ctx' argument must be a Context object" = is(ctx, "tiledb_ctx")) - object@ptr <- libtiledb_array_schema_evolution_add_enumeration(ctx@ptr, object@ptr, name, - enums, FALSE, ordered) - invisible(object) +tiledb_array_schema_evolution_add_enumeration <- function( + object, + name, + enums, + ordered = FALSE, + ctx = tiledb_get_context() +) { + stopifnot( + "The first argument must be an Array Schema Evolution object" = + is(object, "tiledb_array_schema_evolution"), + "The 'name' argument must be a scalar character object" = + is.character(name) && length(name) == 1, + "The 'enumlist' argument must be a character object" = is.character(enums), + "This function needs TileDB 2.17.0 or later" = tiledb_version(TRUE) >= "2.17.0", + "The 'ctx' argument must be a Context object" = is(ctx, "tiledb_ctx") + ) + object@ptr <- libtiledb_array_schema_evolution_add_enumeration( + ctx@ptr, object@ptr, name, + enums, FALSE, ordered + ) + invisible(object) } #' Drop an Enumeration given by name from a TileDB Array Schema Evolution object @@ -113,12 +129,14 @@ tiledb_array_schema_evolution_add_enumeration <- function(object, name, enums, o #' @return The modified 'array_schema_evolution' object, invisibly #' @export tiledb_array_schema_evolution_drop_enumeration <- function(object, attrname) { - stopifnot("The first argument must be an Array Schema Evolution object" = - is(object, "tiledb_array_schema_evolution"), - "The 'attrname' argument must be a character variable" = is.character(attrname), - "This function needs TileDB 2.17.0 or later" = tiledb_version(TRUE) >= "2.17.0") - object@ptr <- libtiledb_array_schema_evolution_drop_enumeration(object@ptr, attrname) - invisible(object) + stopifnot( + "The first argument must be an Array Schema Evolution object" = + is(object, "tiledb_array_schema_evolution"), + "The 'attrname' argument must be a character variable" = is.character(attrname), + "This function needs TileDB 2.17.0 or later" = tiledb_version(TRUE) >= "2.17.0" + ) + object@ptr <- libtiledb_array_schema_evolution_drop_enumeration(object@ptr, attrname) + invisible(object) } #' Evolve an Array Schema by adding an empty Enumeration @@ -132,21 +150,29 @@ tiledb_array_schema_evolution_drop_enumeration <- function(object, attrname) { #' or \code{ordered} (when \code{TRUE}) #' @param ctx Optional tiledb_ctx object #' @export -tiledb_array_schema_evolution_add_enumeration_empty <- function(ase, enum_name, type_str = "ASCII", - cell_val_num = NA_integer_, - ordered = FALSE, - ctx = tiledb_get_context()) { - stopifnot("Argument 'ase' must be an Array Schema Evolution object" = - is(ase, "tiledb_array_schema_evolution"), - "Argument 'enum_name' must be character" = is.character(enum_name), - "Argument 'type_str' must be character" = is.character(type_str), - "Argument 'cell_val_num' must be integer" = is.integer(cell_val_num), - "Argument 'ordered' must be logical" = is.logical(ordered), - "Argument 'ctx' must be a 'tiledb_ctx'" = is(ctx, "tiledb_ctx")) - ase@ptr <- libtiledb_array_schema_evolution_add_enumeration_empty(ctx@ptr, ase@ptr, - enum_name, type_str, cell_val_num, - ordered) - ase +tiledb_array_schema_evolution_add_enumeration_empty <- function( + ase, + enum_name, + type_str = "ASCII", + cell_val_num = NA_integer_, + ordered = FALSE, + ctx = tiledb_get_context() +) { + stopifnot( + "Argument 'ase' must be an Array Schema Evolution object" = + is(ase, "tiledb_array_schema_evolution"), + "Argument 'enum_name' must be character" = is.character(enum_name), + "Argument 'type_str' must be character" = is.character(type_str), + "Argument 'cell_val_num' must be integer" = is.integer(cell_val_num), + "Argument 'ordered' must be logical" = is.logical(ordered), + "Argument 'ctx' must be a 'tiledb_ctx'" = is(ctx, "tiledb_ctx") + ) + ase@ptr <- libtiledb_array_schema_evolution_add_enumeration_empty( + ctx@ptr, ase@ptr, + enum_name, type_str, cell_val_num, + ordered + ) + ase } #' Extend an Evolution via Array Schema Evolution @@ -162,22 +188,31 @@ tiledb_array_schema_evolution_add_enumeration_empty <- function(ase, enum_name, #' @param ctx Optional tiledb_ctx object #' @return The modified ArraySchemaEvolution object #' @export -tiledb_array_schema_evolution_extend_enumeration <- function(ase, array, enum_name, - new_values, nullable = FALSE, - ordered = FALSE, - ctx = tiledb_get_context()) { - stopifnot("Argument 'ase' must be an Array Schema Evolution object" = - is(ase, "tiledb_array_schema_evolution"), - "Argument 'array' must be a TileDB Array" = is(array, "tiledb_array"), - "Argument 'enum_name' must be character" = is.character(enum_name), - "Argument 'new_values' must be character" = is.character(new_values), - "Argument 'nullable' must be logical" = is.logical(nullable), - "Argument 'ordered' must be logical" = is.logical(ordered), - "Argument 'ctx' must be a 'tiledb_ctx'" = is(ctx, "tiledb_ctx")) - ase@ptr <- libtiledb_array_schema_evolution_extend_enumeration(ctx@ptr, ase@ptr, array@ptr, - enum_name, new_values, - nullable, ordered) - ase +tiledb_array_schema_evolution_extend_enumeration <- function( + ase, + array, + enum_name, + new_values, + nullable = FALSE, + ordered = FALSE, + ctx = tiledb_get_context() +) { + stopifnot( + "Argument 'ase' must be an Array Schema Evolution object" = + is(ase, "tiledb_array_schema_evolution"), + "Argument 'array' must be a TileDB Array" = is(array, "tiledb_array"), + "Argument 'enum_name' must be character" = is.character(enum_name), + "Argument 'new_values' must be character" = is.character(new_values), + "Argument 'nullable' must be logical" = is.logical(nullable), + "Argument 'ordered' must be logical" = is.logical(ordered), + "Argument 'ctx' must be a 'tiledb_ctx'" = is(ctx, "tiledb_ctx") + ) + ase@ptr <- libtiledb_array_schema_evolution_extend_enumeration( + ctx@ptr, ase@ptr, array@ptr, + enum_name, new_values, + nullable, ordered + ) + ase } #' Expand an the Current Domain of an Array via Array Schema Evolution @@ -187,10 +222,12 @@ tiledb_array_schema_evolution_extend_enumeration <- function(ase, array, enum_na #' @return The modified ArraySchemaEvolution object #' @export tiledb_array_schema_evolution_expand_current_domain <- function(ase, cd) { - stopifnot("Argument 'ase' must be an Array Schema Evolution object" = - is(ase, "tiledb_array_schema_evolution"), - "Argument 'cd' must be a CurrentDomain object" = is(cd, "tiledb_current_domain"), - "This function needs TileDB 2.26.0 or later" = tiledb_version(TRUE) >= "2.26.0") - ase@ptr <- libtiledb_array_schema_evolution_expand_current_domain(ase@ptr, cd@ptr) - ase + stopifnot( + "Argument 'ase' must be an Array Schema Evolution object" = + is(ase, "tiledb_array_schema_evolution"), + "Argument 'cd' must be a CurrentDomain object" = is(cd, "tiledb_current_domain"), + "This function needs TileDB 2.26.0 or later" = tiledb_version(TRUE) >= "2.26.0" + ) + ase@ptr <- libtiledb_array_schema_evolution_expand_current_domain(ase@ptr, cd@ptr) + ase } diff --git a/R/ArrowIO.R b/R/ArrowIO.R index c045de5719..a4c095f817 100644 --- a/R/ArrowIO.R +++ b/R/ArrowIO.R @@ -31,10 +31,12 @@ ##' with the Arrow Schema stored as the external pointer tag) classed as an S3 object ##' @export tiledb_query_export_buffer <- function(query, name, ctx = tiledb_get_context()) { - stopifnot("The 'query' argument must be a tiledb query" = is(query, "tiledb_query"), - "The 'name' argument must be character" = is.character(name)) - res <- libtiledb_query_export_buffer(ctx@ptr, query@ptr, name) - res + stopifnot( + "The 'query' argument must be a tiledb query" = is(query, "tiledb_query"), + "The 'name' argument must be character" = is.character(name) + ) + res <- libtiledb_query_export_buffer(ctx@ptr, query@ptr, name) + res } ##' Import to Query Buffer from Pair of Arrow IO Pointers @@ -49,12 +51,14 @@ tiledb_query_export_buffer <- function(query, name, ctx = tiledb_get_context()) ##' @return The update Query external pointer is returned ##' @export tiledb_query_import_buffer <- function(query, name, nanoarrowptr, ctx = tiledb_get_context()) { - stopifnot("The 'query' argument must be a tiledb query" = is(query, "tiledb_query"), - "The 'name' argument must be character" = is.character(name), - "The 'nanoarrowptr' argument must be an 'nanoarrow' array object" = - inherits(nanoarrowptr, "nanoarrow_array")) - query@ptr <- libtiledb_query_import_buffer(ctx@ptr, query@ptr, name, nanoarrowptr) - query + stopifnot( + "The 'query' argument must be a tiledb query" = is(query, "tiledb_query"), + "The 'name' argument must be character" = is.character(name), + "The 'nanoarrowptr' argument must be an 'nanoarrow' array object" = + inherits(nanoarrowptr, "nanoarrow_array") + ) + query@ptr <- libtiledb_query_import_buffer(ctx@ptr, query@ptr, name, nanoarrowptr) + query } ##' (Deprecated) Allocate (or Release) Arrow Array and Schema Pointers @@ -67,45 +71,45 @@ tiledb_query_import_buffer <- function(query, name, nanoarrowptr, ctx = tiledb_g ##' @return The allocating functions return the requested pointer ##' @export tiledb_arrow_array_ptr <- function() { - .Deprecated(msg="tiledb_arrow_array_ptr() is deprecated, please use nanoarrow::nanoarrow_allocate_array() instead.") - res <- nanoarrow::nanoarrow_allocate_array() + .Deprecated(msg = "tiledb_arrow_array_ptr() is deprecated, please use nanoarrow::nanoarrow_allocate_array() instead.") + res <- nanoarrow::nanoarrow_allocate_array() } ##' @rdname tiledb_arrow_array_ptr ##' @export tiledb_arrow_schema_ptr <- function() { - .Deprecated(msg="tiledb_arrow_schema_ptr() is deprecated, please use nanoarrow::nanoarrow_allocate_schema() instead.") - res <- nanoarrow::nanoarrow_allocate_schema() + .Deprecated(msg = "tiledb_arrow_schema_ptr() is deprecated, please use nanoarrow::nanoarrow_allocate_schema() instead.") + res <- nanoarrow::nanoarrow_allocate_schema() } ##' @rdname tiledb_arrow_array_ptr ##' @export tiledb_arrow_array_del <- function(ptr) { - .Deprecated(msg="tiledb_arrow_array_del() is deprecated, please use nanoarrow::nanoarrow_pointer_release() instead.") - nanoarrow::nanoarrow_pointer_release(ptr) + .Deprecated(msg = "tiledb_arrow_array_del() is deprecated, please use nanoarrow::nanoarrow_pointer_release() instead.") + nanoarrow::nanoarrow_pointer_release(ptr) } ##' @rdname tiledb_arrow_array_ptr ##' @export tiledb_arrow_schema_del <- function(ptr) { - .Deprecated(msg="tiledb_arrow_schema_del() is deprecated, please use nanoarrow::nanoarrow_pointer_release() instead.") - nanoarrow::nanoarrow_pointer_release(ptr) + .Deprecated(msg = "tiledb_arrow_schema_del() is deprecated, please use nanoarrow::nanoarrow_pointer_release() instead.") + nanoarrow::nanoarrow_pointer_release(ptr) } ##' @noRd .tiledb_set_arrow_config <- function(ctx = tiledb_get_context()) { - cfg <- tiledb_config() # for var-num columns such as char we need these - cfg["sm.var_offsets.bitsize"] <- "64" - cfg["sm.var_offsets.mode"] <- "elements" - cfg["sm.var_offsets.extra_element"] <- "true" - ctx <- tiledb_ctx(cfg) + cfg <- tiledb_config() # for var-num columns such as char we need these + cfg["sm.var_offsets.bitsize"] <- "64" + cfg["sm.var_offsets.mode"] <- "elements" + cfg["sm.var_offsets.extra_element"] <- "true" + ctx <- tiledb_ctx(cfg) } ##' @noRd .tiledb_unset_arrow_config <- function(ctx = tiledb_get_context()) { - cfg <- tiledb_config() # for var-num columns such as char we need these - cfg["sm.var_offsets.bitsize"] <- "64" - cfg["sm.var_offsets.mode"] <- "bytes" - cfg["sm.var_offsets.extra_element"] <- "false" - ctx <- tiledb_ctx(cfg) + cfg <- tiledb_config() # for var-num columns such as char we need these + cfg["sm.var_offsets.bitsize"] <- "64" + cfg["sm.var_offsets.mode"] <- "bytes" + cfg["sm.var_offsets.extra_element"] <- "false" + ctx <- tiledb_ctx(cfg) } diff --git a/R/Attribute.R b/R/Attribute.R index 026a03a142..34511ae429 100644 --- a/R/Attribute.R +++ b/R/Attribute.R @@ -25,11 +25,14 @@ #' @slot ptr External pointer to the underlying implementation #' @exportClass tiledb_attr setClass("tiledb_attr", - slots = list(ptr = "externalptr")) + slots = list(ptr = "externalptr") +) tiledb_attr.from_ptr <- function(ptr) { - stopifnot(`The 'ptr' argument must be a non-NULL external pointer to an Attribute instance` = - !missing(ptr) && is(ptr, "externalptr") && !is.null(ptr)) + stopifnot( + `The 'ptr' argument must be a non-NULL external pointer to an Attribute instance` = + !missing(ptr) && is(ptr, "externalptr") && !is.null(ptr) + ) new("tiledb_attr", ptr = ptr) } @@ -46,35 +49,43 @@ tiledb_attr.from_ptr <- function(ptr) { #' @param ctx tiledb_ctx object (optional) #' @return `tiledb_dim` object #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' flt <- tiledb_filter_list(list(tiledb_filter("GZIP"))) -#' attr <- tiledb_attr(name = "a1", type = "INT32", -#' filter_list = flt) +#' attr <- tiledb_attr( +#' name = "a1", type = "INT32", +#' filter_list = flt +#' ) #' attr #' #' @importFrom methods new #' @export -tiledb_attr <- function(name, - type, - filter_list = tiledb_filter_list(), - ncells = 1, - nullable = FALSE, - enumeration = NULL, - ctx = tiledb_get_context() - ) { - if (missing(name)) name <- "" - if (is.na(ncells)) ncells <- NA_integer_ # the specific NA for ints (as basic NA is bool) - stopifnot("The 'name' argument must be a scalar string" = is.scalar(name, "character"), - "The 'type' argument is mandatory" = !missing(type), - "The 'ncells' argument must be numeric or NA" = is.numeric(ncells) || is.na(ncells), - "The 'filter_list' argument must be a tiledb_filter_list instance" = - is(filter_list, "tiledb_filter_list"), - "The 'ctx' argument must be a tiledb_ctx" = is(ctx, "tiledb_ctx")) - ptr <- libtiledb_attribute(ctx@ptr, name, type, filter_list@ptr, ncells, nullable) - attr <- new("tiledb_attr", ptr = ptr) - if (!is.null(enumeration)) - attr <- tiledb_attribute_set_enumeration_name(attr, name, ctx) - invisible(attr) +tiledb_attr <- function( + name, + type, + filter_list = tiledb_filter_list(), + ncells = 1, + nullable = FALSE, + enumeration = NULL, + ctx = tiledb_get_context() +) { + if (missing(name)) name <- "" + if (is.na(ncells)) ncells <- NA_integer_ # the specific NA for ints (as basic NA is bool) + stopifnot( + "The 'name' argument must be a scalar string" = is.scalar(name, "character"), + "The 'type' argument is mandatory" = !missing(type), + "The 'ncells' argument must be numeric or NA" = is.numeric(ncells) || is.na(ncells), + "The 'filter_list' argument must be a tiledb_filter_list instance" = + is(filter_list, "tiledb_filter_list"), + "The 'ctx' argument must be a tiledb_ctx" = is(ctx, "tiledb_ctx") + ) + ptr <- libtiledb_attribute(ctx@ptr, name, type, filter_list@ptr, ncells, nullable) + attr <- new("tiledb_attr", ptr = ptr) + if (!is.null(enumeration)) { + attr <- tiledb_attribute_set_enumeration_name(attr, name, ctx) + } + invisible(attr) } #' Raw display of an attribute object @@ -85,32 +96,35 @@ tiledb_attr <- function(name, #' @param object An attribute object #' @export setMethod("raw_dump", - signature(object = "tiledb_attr"), - definition = function(object) libtiledb_attribute_dump(object@ptr)) + signature(object = "tiledb_attr"), + definition = function(object) libtiledb_attribute_dump(object@ptr) +) # internal function returning text use here and in other higher-level show() methods -.as_text_attribute <- function(object, arrptr=NULL) { - fl <- filter_list(object) - ndct <- 0 # default - dct <- character() # default - ord <- FALSE # default - if (!is.null(arrptr)) { - if (!libtiledb_array_is_open_for_reading(arrptr)) arrptr <- libtiledb_array_open_with_ptr(arrptr, "READ") - if (tiledb_attribute_has_enumeration(object)) { - dct <- tiledb_attribute_get_enumeration_ptr(object, arrptr) - ord <- tiledb_attribute_is_ordered_enumeration_ptr(object, arrptr) - ndct <- length(dct) - } +.as_text_attribute <- function(object, arrptr = NULL) { + fl <- filter_list(object) + ndct <- 0 # default + dct <- character() # default + ord <- FALSE # default + if (!is.null(arrptr)) { + if (!libtiledb_array_is_open_for_reading(arrptr)) arrptr <- libtiledb_array_open_with_ptr(arrptr, "READ") + if (tiledb_attribute_has_enumeration(object)) { + dct <- tiledb_attribute_get_enumeration_ptr(object, arrptr) + ord <- tiledb_attribute_is_ordered_enumeration_ptr(object, arrptr) + ndct <- length(dct) } - dictionary_txt <- if (ord) "ordered_dictionary" else "dictionary" - txt <- paste0("tiledb_attr(name=\"", name(object), "\", ", - "type=\"", datatype(object), "\", ", - "ncells=", cell_val_num(object), ", ", - "nullable=", tiledb_attribute_get_nullable(object), - if (nfilters(fl) > 0) paste0(", filter_list=", .as_text_filter_list(fl)), - if (ndct > 0) paste0(", ", dictionary_txt, "=c(\"", paste(dct[seq(1, min(5, ndct))], collapse="\",\""), if (ndct > 5) "\",...", "\")")) - txt <- paste0(txt, ")") - txt + } + dictionary_txt <- if (ord) "ordered_dictionary" else "dictionary" + txt <- paste0( + "tiledb_attr(name=\"", name(object), "\", ", + "type=\"", datatype(object), "\", ", + "ncells=", cell_val_num(object), ", ", + "nullable=", tiledb_attribute_get_nullable(object), + if (nfilters(fl) > 0) paste0(", filter_list=", .as_text_filter_list(fl)), + if (ndct > 0) paste0(", ", dictionary_txt, "=c(\"", paste(dct[seq(1, min(5, ndct))], collapse = "\",\""), if (ndct > 5) "\",...", "\")") + ) + txt <- paste0(txt, ")") + txt } #' Prints an attribute object @@ -118,10 +132,11 @@ setMethod("raw_dump", #' @param object An attribute object #' @export setMethod("show", - signature(object = "tiledb_attr"), - definition = function(object) { + signature(object = "tiledb_attr"), + definition = function(object) { cat(.as_text_attribute(object), "\n") -}) + } +) #' @rdname generics @@ -133,7 +148,9 @@ setGeneric("name", function(object) standardGeneric("name")) #' @param object `tiledb_attr` object #' @return string name, empty string if the attribute is anonymous #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' a1 <- tiledb_attr("a1", type = "INT32") #' name(a1) #' @@ -141,10 +158,12 @@ setGeneric("name", function(object) standardGeneric("name")) #' name(a2) #' #' @export -setMethod("name", signature(object = "tiledb_attr"), - function(object) { - libtiledb_attribute_get_name(object@ptr) - }) +setMethod( + "name", signature(object = "tiledb_attr"), + function(object) { + libtiledb_attribute_get_name(object@ptr) + } +) #' @rdname generics #' @export @@ -162,10 +181,12 @@ setGeneric("datatype", function(object) standardGeneric("datatype")) #' datatype(a2) #' #' @export -setMethod("datatype", signature(object = "tiledb_attr"), - function(object) { - libtiledb_attribute_get_type(object@ptr) - }) +setMethod( + "datatype", signature(object = "tiledb_attr"), + function(object) { + libtiledb_attribute_get_type(object@ptr) + } +) ## Generic in ArraySchema.R @@ -174,8 +195,13 @@ setMethod("datatype", signature(object = "tiledb_attr"), #' @param object TileDB Attribute #' @return a tiledb_filter_list object #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} -#' attr <- tiledb_attr(type = "INT32", filter_list=tiledb_filter_list(list(tiledb_filter("ZSTD")))) +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } +#' attr <- tiledb_attr( +#' type = "INT32", +#' filter_list = tiledb_filter_list(list(tiledb_filter("ZSTD"))) +#' ) #' filter_list(attr) #' #' @export @@ -204,16 +230,22 @@ setGeneric("cell_val_num", function(object) standardGeneric("cell_val_num")) #' @rdname tiledb_attribute_get_cell_val_num #' @export -setMethod("cell_val_num", signature(object = "tiledb_attr"), function(object) { - libtiledb_attribute_get_cell_val_num(object@ptr) -}) +setMethod( + "cell_val_num", + signature(object = "tiledb_attr"), + definition = function(object) { + libtiledb_attribute_get_cell_val_num(object@ptr) + } +) #' Return the number of scalar values per attribute cell #' #' @param object `tiledb_attr` object #' @return integer number of cells #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' a1 <- tiledb_attr("a1", type = "FLOAT64", ncells = 1) #' cell_val_num(a1) #' @export @@ -229,10 +261,14 @@ setGeneric("cell_val_num<-", function(x, value) standardGeneric("cell_val_num<-" #' @rdname tiledb_attribute_set_cell_val_num #' @export -setReplaceMethod("cell_val_num", signature("tiledb_attr"), function(x, value) { - libtiledb_attribute_set_cell_val_num(x@ptr, value) - x -}) +setReplaceMethod( + "cell_val_num", + signature("tiledb_attr"), + function(x, value) { + libtiledb_attribute_set_cell_val_num(x@ptr, value) + x + } +) #' Set the number of scalar values per attribute cell #' @@ -252,7 +288,9 @@ tiledb_attribute_set_cell_val_num <- function(x, value) { #' @param object `tiledb_attr` object #' @return TRUE or FALSE #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' a1 <- tiledb_attr("a1", type = "FLOAT64") #' is.anonymous(a1) #' @@ -276,7 +314,7 @@ is.anonymous.tiledb_attr <- function(object) { #' @return The fill value for the attribute #' @export tiledb_attribute_get_fill_value <- function(attr) { - stopifnot(attr_object=is(attr, "tiledb_attr")) + stopifnot(attr_object = is(attr, "tiledb_attr")) libtiledb_attribute_get_fill_value(attr@ptr) } @@ -287,8 +325,10 @@ tiledb_attribute_get_fill_value <- function(attr) { #' @return \code{NULL} is returned invisibly #' @export tiledb_attribute_set_fill_value <- function(attr, value) { - stopifnot(`The first argument must be an attribute` = is(attr, "tiledb_attr"), - `The second argument must be int, numeric or char` = is.integer(value) || is.numeric(value) || is.character(value)) + stopifnot( + `The first argument must be an attribute` = is(attr, "tiledb_attr"), + `The second argument must be int, numeric or char` = is.integer(value) || is.numeric(value) || is.character(value) + ) libtiledb_attribute_set_fill_value(attr@ptr, value) invisible() } @@ -320,8 +360,10 @@ tiledb_attribute_get_cell_size <- function(attr) { #' @return Nothing is returned #' @export tiledb_attribute_set_nullable <- function(attr, flag) { - stopifnot(`The first argument must be an attribute` = is(attr, "tiledb_attr"), - `The second argument must be a logical` = is.logical(flag) && !is.na(flag)) + stopifnot( + `The first argument must be an attribute` = is(attr, "tiledb_attr"), + `The second argument must be a logical` = is.logical(flag) && !is.na(flag) + ) libtiledb_attribute_set_nullable(attr@ptr, flag) } @@ -331,8 +373,8 @@ tiledb_attribute_set_nullable <- function(attr, flag) { #' @return A boolean value with the \sQuote{Nullable} status #' @export tiledb_attribute_get_nullable <- function(attr) { - stopifnot(`The argument must be an attribute` = is(attr, "tiledb_attr")) - libtiledb_attribute_get_nullable(attr@ptr) + stopifnot(`The argument must be an attribute` = is(attr, "tiledb_attr")) + libtiledb_attribute_get_nullable(attr@ptr) } #' Test if TileDB Attribute has an Enumeration @@ -341,9 +383,12 @@ tiledb_attribute_get_nullable <- function(attr) { #' @param ctx A Tiledb Context object (optional) #' @return A logical value indicating if the attribute has an enumeration #' @export -tiledb_attribute_has_enumeration <- function(attr, ctx = tiledb_get_context()) { - stopifnot("The 'attr' argument must be an attribute" = is(attr, "tiledb_attr")) - libtiledb_attribute_has_enumeration(ctx@ptr, attr@ptr) +tiledb_attribute_has_enumeration <- function( + attr, + ctx = tiledb_get_context() +) { + stopifnot("The 'attr' argument must be an attribute" = is(attr, "tiledb_attr")) + libtiledb_attribute_has_enumeration(ctx@ptr, attr@ptr) } #' Get the TileDB Attribute Enumeration @@ -353,19 +398,31 @@ tiledb_attribute_has_enumeration <- function(attr, ctx = tiledb_get_context()) { #' @param ctx A Tiledb Context object (optional) #' @return A character vector with the enumeration (of length zero if none) #' @export -tiledb_attribute_get_enumeration <- function(attr, arr, ctx = tiledb_get_context()) { - stopifnot("The 'attr' argument must be an attribute" = is(attr, "tiledb_attr"), - "The 'arr' argument must be an array" = is(arr, "tiledb_array")) - libtiledb_attribute_get_enumeration(ctx@ptr, attr@ptr, arr@ptr) +tiledb_attribute_get_enumeration <- function( + attr, + arr, + ctx = tiledb_get_context() +) { + stopifnot( + "The 'attr' argument must be an attribute" = is(attr, "tiledb_attr"), + "The 'arr' argument must be an array" = is(arr, "tiledb_array") + ) + libtiledb_attribute_get_enumeration(ctx@ptr, attr@ptr, arr@ptr) } #' @rdname tiledb_attribute_get_enumeration #' @param arrptr A Tiledb Array object pointer #' @export -tiledb_attribute_get_enumeration_ptr <- function(attr, arrptr, ctx = tiledb_get_context()) { - stopifnot("The 'attr' argument must be an attribute" = is(attr, "tiledb_attr"), - "The 'arrptr' argument must be an external pointer" = is(arrptr, "externalptr")) - libtiledb_attribute_get_enumeration(ctx@ptr, attr@ptr, arrptr) +tiledb_attribute_get_enumeration_ptr <- function( + attr, + arrptr, + ctx = tiledb_get_context() +) { + stopifnot( + "The 'attr' argument must be an attribute" = is(attr, "tiledb_attr"), + "The 'arrptr' argument must be an external pointer" = is(arrptr, "externalptr") + ) + libtiledb_attribute_get_enumeration(ctx@ptr, attr@ptr, arrptr) } #' Set a TileDB Attribute Enumeration Name @@ -375,11 +432,17 @@ tiledb_attribute_get_enumeration_ptr <- function(attr, arrptr, ctx = tiledb_get_ #' @param ctx A Tiledb Context object (optional) #' @return The modified TileDB Attribute object #' @export -tiledb_attribute_set_enumeration_name <- function(attr, enum_name, ctx = tiledb_get_context()) { - stopifnot("The 'attr' argument must be an attribute" = is(attr, "tiledb_attr"), - "The 'enum_name' argument must be character" = is.character(enum_name)) - attr@ptr <- libtiledb_attribute_set_enumeration(ctx@ptr, attr@ptr, enum_name) - attr +tiledb_attribute_set_enumeration_name <- function( + attr, + enum_name, + ctx = tiledb_get_context() +) { + stopifnot( + "The 'attr' argument must be an attribute" = is(attr, "tiledb_attr"), + "The 'enum_name' argument must be character" = is.character(enum_name) + ) + attr@ptr <- libtiledb_attribute_set_enumeration(ctx@ptr, attr@ptr, enum_name) + attr } #' Check if TileDB Attribute Enumeration is Ordered @@ -389,32 +452,56 @@ tiledb_attribute_set_enumeration_name <- function(attr, enum_name, ctx = tiledb_ #' @param ctx A Tiledb Context object (optional) #' @return A character vector with the enumeration (of length zero if none) #' @export -tiledb_attribute_is_ordered_enumeration_ptr <- function(attr, arrptr, ctx = tiledb_get_context()) { - stopifnot("The 'attr' argument must be an attribute" = is(attr, "tiledb_attr"), - "The 'arrptr' argument must be an external pointer" = is(arrptr, "externalptr")) - libtiledb_attribute_is_ordered_enumeration(ctx@ptr, attr@ptr, arrptr) +tiledb_attribute_is_ordered_enumeration_ptr <- function( + attr, + arrptr, + ctx = tiledb_get_context() +) { + stopifnot( + "The 'attr' argument must be an attribute" = is(attr, "tiledb_attr"), + "The 'arrptr' argument must be an external pointer" = is(arrptr, "externalptr") + ) + libtiledb_attribute_is_ordered_enumeration(ctx@ptr, attr@ptr, arrptr) } # internal function to access enumeration data type #' @noRd -tiledb_attribute_get_enumeration_type <- function(attr, arr, ctx = tiledb_get_context()) { - stopifnot("The 'attr' argument must be an attribute" = is(attr, "tiledb_attr"), - "The 'arr' argument must be an array" = is(arr, "tiledb_array")) - libtiledb_attribute_get_enumeration_type(ctx@ptr, attr@ptr, arr@ptr) +tiledb_attribute_get_enumeration_type <- function( + attr, + arr, + ctx = tiledb_get_context() +) { + stopifnot( + "The 'attr' argument must be an attribute" = is(attr, "tiledb_attr"), + "The 'arr' argument must be an array" = is(arr, "tiledb_array") + ) + libtiledb_attribute_get_enumeration_type(ctx@ptr, attr@ptr, arr@ptr) } # internal function to access enumeration data type #' @noRd -tiledb_attribute_get_enumeration_type_ptr <- function(attr, arrptr, ctx = tiledb_get_context()) { - stopifnot("The 'attr' argument must be an attribute" = is(attr, "tiledb_attr"), - "The 'arrptr' argument must be an external pointer" = is(arrptr, "externalptr")) - libtiledb_attribute_get_enumeration_type(ctx@ptr, attr@ptr, arrptr) +tiledb_attribute_get_enumeration_type_ptr <- function( + attr, + arrptr, + ctx = tiledb_get_context() +) { + stopifnot( + "The 'attr' argument must be an attribute" = is(attr, "tiledb_attr"), + "The 'arrptr' argument must be an external pointer" = is(arrptr, "externalptr") + ) + libtiledb_attribute_get_enumeration_type(ctx@ptr, attr@ptr, arrptr) } # internal function to get (non-string) enumeration vector #' @noRd -tiledb_attribute_get_enumeration_vector_ptr <- function(attr, arrptr, ctx = tiledb_get_context()) { - stopifnot("The 'attr' argument must be an attribute" = is(attr, "tiledb_attr"), - "The 'arrptr' argument must be an external pointer" = is(arrptr, "externalptr")) - libtiledb_attribute_get_enumeration_vector(ctx@ptr, attr@ptr, arrptr) +tiledb_attribute_get_enumeration_vector_ptr <- function( + attr, + arrptr, + ctx = tiledb_get_context() +) { + stopifnot( + "The 'attr' argument must be an attribute" = is(attr, "tiledb_attr"), + "The 'arrptr' argument must be an external pointer" = is(arrptr, "externalptr") + ) + libtiledb_attribute_get_enumeration_vector(ctx@ptr, attr@ptr, arrptr) } diff --git a/R/BatchedQuery.R b/R/BatchedQuery.R index c565ea3c57..87c9e85f39 100644 --- a/R/BatchedQuery.R +++ b/R/BatchedQuery.R @@ -1,4 +1,3 @@ - #' Create a \sQuote{batched} query object #' #' Batched queries return an initial result set even when it is incomplete. Where @@ -13,256 +12,264 @@ #' to a TileDB Query object along with other support variables used by \code{fetchBatched} #' @export createBatched <- function(x) { - ## add defaults, shortcut for now - i <- j <- k <- NULL - #verbose <- getOption("verbose", FALSE) - - ## ## deal with possible n-dim indexing - ## ndlist <- nd_index_from_syscall(sys.call(), parent.frame()) - ## if (length(ndlist) >= 0) { - ## if (length(ndlist) >= 1 && !is.null(ndlist[[1]])) i <- ndlist[[1]] - ## if (length(ndlist) >= 2 && !is.null(ndlist[[2]])) j <- ndlist[[2]] - ## if (length(ndlist) >= 3 && !is.null(ndlist[[3]])) k <- ndlist[[3]] - ## if (length(ndlist) >= 4) message("Indices beyond the third dimension not supported in [i,j,k] form. Use selected_ranges().") - ## } - - ctx <- x@ctx - uri <- x@uri - sel <- x@attrs - sch <- tiledb::schema(x) - dom <- tiledb::domain(sch) - layout <- x@query_layout - asint64 <- x@datetimes_as_int64 - enckey <- x@encryption_key - tstamp <- x@timestamp_end - - sparse <- libtiledb_array_schema_sparse(sch@ptr) - - dims <- tiledb::dimensions(dom) - dimnames <- sapply(dims, function(d) libtiledb_dim_get_name(d@ptr)) - dimtypes <- sapply(dims, function(d) libtiledb_dim_get_datatype(d@ptr)) - dimvarnum <- sapply(dims, function(d) libtiledb_dim_get_cell_val_num(d@ptr)) - dimnullable <- sapply(dims, function(d) FALSE) - - attrs <- tiledb::attrs(schema(x)) - attrnames <- unname(sapply(attrs, function(a) libtiledb_attribute_get_name(a@ptr))) - attrtypes <- unname(sapply(attrs, function(a) libtiledb_attribute_get_type(a@ptr))) - attrvarnum <- unname(sapply(attrs, function(a) libtiledb_attribute_get_cell_val_num(a@ptr))) - attrnullable <- unname(sapply(attrs, function(a) libtiledb_attribute_get_nullable(a@ptr))) - if (length(sel)==1 && is.na(sel[1])) { # special case of NA selecting no attrs - attrnames <- character() - attrtypes <- character() - attrvarnum <- integer() - attrnullable <- logical() - } - - if (length(sel) != 0 && !any(is.na(sel))) { - ind <- match(sel, attrnames) - if (length(ind) == 0) { - stop("Only non-existing columns selected.", call.=FALSE) - } - attrnames <- attrnames[ind] - attrtypes <- attrtypes[ind] - attrvarnum <- attrvarnum[ind] - attrnullable <- attrnullable[ind] + ## add defaults, shortcut for now + i <- j <- k <- NULL + # verbose <- getOption("verbose", FALSE) + + ## ## deal with possible n-dim indexing + ## ndlist <- nd_index_from_syscall(sys.call(), parent.frame()) + ## if (length(ndlist) >= 0) { + ## if (length(ndlist) >= 1 && !is.null(ndlist[[1]])) i <- ndlist[[1]] + ## if (length(ndlist) >= 2 && !is.null(ndlist[[2]])) j <- ndlist[[2]] + ## if (length(ndlist) >= 3 && !is.null(ndlist[[3]])) k <- ndlist[[3]] + ## if (length(ndlist) >= 4) message("Indices beyond the third dimension not supported in [i,j,k] form. Use selected_ranges().") + ## } + + ctx <- x@ctx + uri <- x@uri + sel <- x@attrs + sch <- tiledb::schema(x) + dom <- tiledb::domain(sch) + layout <- x@query_layout + asint64 <- x@datetimes_as_int64 + enckey <- x@encryption_key + tstamp <- x@timestamp_end + + sparse <- libtiledb_array_schema_sparse(sch@ptr) + + dims <- tiledb::dimensions(dom) + dimnames <- sapply(dims, function(d) libtiledb_dim_get_name(d@ptr)) + dimtypes <- sapply(dims, function(d) libtiledb_dim_get_datatype(d@ptr)) + dimvarnum <- sapply(dims, function(d) libtiledb_dim_get_cell_val_num(d@ptr)) + dimnullable <- sapply(dims, function(d) FALSE) + + attrs <- tiledb::attrs(schema(x)) + attrnames <- unname(sapply(attrs, function(a) libtiledb_attribute_get_name(a@ptr))) + attrtypes <- unname(sapply(attrs, function(a) libtiledb_attribute_get_type(a@ptr))) + attrvarnum <- unname(sapply(attrs, function(a) libtiledb_attribute_get_cell_val_num(a@ptr))) + attrnullable <- unname(sapply(attrs, function(a) libtiledb_attribute_get_nullable(a@ptr))) + if (length(sel) == 1 && is.na(sel[1])) { # special case of NA selecting no attrs + attrnames <- character() + attrtypes <- character() + attrvarnum <- integer() + attrnullable <- logical() + } + + if (length(sel) != 0 && !any(is.na(sel))) { + ind <- match(sel, attrnames) + if (length(ind) == 0) { + stop("Only non-existing columns selected.", call. = FALSE) } - - if (x@extended) { # if true return dimensions and attributes - allnames <- c(dimnames, attrnames) - alltypes <- c(dimtypes, attrtypes) - allvarnum <- c(dimvarnum, attrvarnum) - allnullable <- c(dimnullable, attrnullable) - } else { # otherwise only return attributes - allnames <- attrnames - alltypes <- attrtypes - allvarnum <- attrvarnum - allnullable <- attrnullable - } - - ## A preference can be set in a local per-user configuration file; if no value - ## is set a fallback from the TileDB config object is used. - memory_budget <- get_allocation_size_preference() - spdl::debug("[createBatched] memory budget is {}", memory_budget) - - if (length(enckey) > 0) { - if (length(tstamp) > 0) { - arrptr <- libtiledb_array_open_at_with_key(ctx@ptr, uri, "READ", enckey, tstamp) - } else { - arrptr <- libtiledb_array_open_with_key(ctx@ptr, uri, "READ", enckey) - } + attrnames <- attrnames[ind] + attrtypes <- attrtypes[ind] + attrvarnum <- attrvarnum[ind] + attrnullable <- attrnullable[ind] + } + + if (x@extended) { # if true return dimensions and attributes + allnames <- c(dimnames, attrnames) + alltypes <- c(dimtypes, attrtypes) + allvarnum <- c(dimvarnum, attrvarnum) + allnullable <- c(dimnullable, attrnullable) + } else { # otherwise only return attributes + allnames <- attrnames + alltypes <- attrtypes + allvarnum <- attrvarnum + allnullable <- attrnullable + } + + ## A preference can be set in a local per-user configuration file; if no value + ## is set a fallback from the TileDB config object is used. + memory_budget <- get_allocation_size_preference() + spdl::debug("[createBatched] memory budget is {}", memory_budget) + + if (length(enckey) > 0) { + if (length(tstamp) > 0) { + arrptr <- libtiledb_array_open_at_with_key(ctx@ptr, uri, "READ", enckey, tstamp) } else { - if (length(tstamp) > 0) { - arrptr <- libtiledb_array_open_at(ctx@ptr, uri, "READ", tstamp) - } else { - arrptr <- libtiledb_array_open(ctx@ptr, uri, "READ") - } - } - if (length(x@timestamp_start) > 0) { - arrptr <- libtiledb_array_set_open_timestamp_start(arrptr, x@timestamp_start) + arrptr <- libtiledb_array_open_with_key(ctx@ptr, uri, "READ", enckey) } - if (length(x@timestamp_end) > 0) { - arrptr <- libtiledb_array_set_open_timestamp_end(arrptr, x@timestamp_end) - } - if (length(x@timestamp_start) > 0 || length(x@timestamp_end) > 0) { - arrptr <- libtiledb_array_reopen(arrptr) - } - - ## helper function to sweep over names and types of domain - getDomain <- function(nm, tp) { - if (tp %in% c("ASCII", "CHAR")) { - libtiledb_array_get_non_empty_domain_var_from_name(arrptr, nm) - } else { - libtiledb_array_get_non_empty_domain_from_name(arrptr, nm, tp) - } + } else { + if (length(tstamp) > 0) { + arrptr <- libtiledb_array_open_at(ctx@ptr, uri, "READ", tstamp) + } else { + arrptr <- libtiledb_array_open(ctx@ptr, uri, "READ") } - nonemptydom <- mapply(getDomain, dimnames, dimtypes, SIMPLIFY=FALSE) - - ## open query - qryptr <- libtiledb_query(ctx@ptr, arrptr, "READ") - qryptr <- libtiledb_query_set_layout(qryptr, if (isTRUE(nzchar(layout))) layout - else { if (sparse) "UNORDERED" else "COL_MAJOR" }) - - ## ranges seem to interfere with the byte/element adjustment below so set up toggle - rangeunset <- TRUE - - ## ensure selected_ranges, if submitted, is of correct length - if (length(x@selected_ranges) != 0 && - length(x@selected_ranges) != length(dimnames) && - is.null(names(x@selected_ranges))) { - stop(paste0("If ranges are selected by index alone (and not named), ", - "one is required for each dimension."), call. = FALSE) + } + if (length(x@timestamp_start) > 0) { + arrptr <- libtiledb_array_set_open_timestamp_start(arrptr, x@timestamp_start) + } + if (length(x@timestamp_end) > 0) { + arrptr <- libtiledb_array_set_open_timestamp_end(arrptr, x@timestamp_end) + } + if (length(x@timestamp_start) > 0 || length(x@timestamp_end) > 0) { + arrptr <- libtiledb_array_reopen(arrptr) + } + + ## helper function to sweep over names and types of domain + getDomain <- function(nm, tp) { + if (tp %in% c("ASCII", "CHAR")) { + libtiledb_array_get_non_empty_domain_var_from_name(arrptr, nm) + } else { + libtiledb_array_get_non_empty_domain_from_name(arrptr, nm, tp) } - - ## 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 + } + nonemptydom <- mapply(getDomain, dimnames, dimtypes, SIMPLIFY = FALSE) + + ## open query + qryptr <- libtiledb_query(ctx@ptr, arrptr, "READ") + qryptr <- libtiledb_query_set_layout(qryptr, if (isTRUE(nzchar(layout))) { + layout + } else { + if (sparse) "UNORDERED" else "COL_MAJOR" + }) + + ## ranges seem to interfere with the byte/element adjustment below so set up toggle + rangeunset <- TRUE + + ## ensure selected_ranges, if submitted, is of correct length + if (length(x@selected_ranges) != 0 && + length(x@selected_ranges) != length(dimnames) && + is.null(names(x@selected_ranges))) { + stop(paste0( + "If ranges are selected by index alone (and not named), ", + "one is required for each dimension." + ), call. = FALSE) + } + + ## 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]] } - - ## selected_ranges may be in different order than dimnames, so reorder if need be - if ((length(x@selected_ranges) == length(dimnames)) - && (!is.null(names(x@selected_ranges))) - && (!identical(names(x@selected_ranges), dimnames))) { - x@selected_ranges <- x@selected_ranges[dimnames] + x@selected_ranges <- fulllist + } + + ## selected_ranges may be in different order than dimnames, so reorder if need be + if ((length(x@selected_ranges) == length(dimnames)) && + (!is.null(names(x@selected_ranges))) && + (!identical(names(x@selected_ranges), dimnames))) { + x@selected_ranges <- x@selected_ranges[dimnames] + } + + ## if selected_ranges is still an empty list, make it an explicit one + if (length(x@selected_ranges) == 0) { + x@selected_ranges <- vector(mode = "list", length = length(dimnames)) + } + + if (!is.null(i)) { + if (!is.null(x@selected_ranges[[1]])) { + stop("Cannot set both 'i' and first element of 'selected_ranges'.", call. = FALSE) } + x@selected_ranges[[1]] <- i + } - ## if selected_ranges is still an empty list, make it an explicit one - if (length(x@selected_ranges) == 0) { - x@selected_ranges <- vector(mode="list", length=length(dimnames)) + if (!is.null(j)) { + if (!is.null(x@selected_ranges[[2]])) { + stop("Cannot set both 'j' and second element of 'selected_ranges'.", call. = FALSE) } + x@selected_ranges[[2]] <- j + } - if (!is.null(i)) { - if (!is.null(x@selected_ranges[[1]])) { - stop("Cannot set both 'i' and first element of 'selected_ranges'.", call. = FALSE) - } - x@selected_ranges[[1]] <- i + if (!is.null(k)) { + if (!is.null(x@selected_ranges[[3]])) { + stop("Cannot set both 'k' and second element of 'selected_ranges'.", call. = FALSE) } - - if (!is.null(j)) { - if (!is.null(x@selected_ranges[[2]])) { - stop("Cannot set both 'j' and second element of 'selected_ranges'.", call. = FALSE) - } - x@selected_ranges[[2]] <- j + x@selected_ranges[[3]] <- k + } + ## (i,j,k) are now done and transferred to x@select_ranges + + + ## if ranges selected, use those + for (k in seq_len(length(x@selected_ranges))) { + sbrptr <- libtiledb_subarray(qryptr) + if (is.null(x@selected_ranges[[k]])) { + ## cat("Adding null dim", k, "on", dimtypes[k], "\n") + vec <- .map2integer64(nonemptydom[[k]], dimtypes[k]) + if (vec[1] != 0 && vec[2] != 0) { # corner case of A[] on empty array + sbrptr <- libtiledb_subarray_add_range_with_type(sbrptr, k - 1L, dimtypes[k], vec[1], vec[2]) + rangeunset <- FALSE + } + } else if (is.null(nrow(x@selected_ranges[[k]]))) { + ## cat("Adding nrow null dim", k, "on", dimtypes[k], "\n") + vec <- x@selected_ranges[[k]] + vec <- .map2integer64(vec, dimtypes[k]) + sbrptr <- libtiledb_subarray_add_range_with_type(sbrptr, k - 1L, dimtypes[k], min(vec), max(vec)) + rangeunset <- FALSE + } else { + ## cat("Adding non-zero dim", k, "on", dimtypes[k], "\n") + m <- x@selected_ranges[[k]] + for (i in seq_len(nrow(m))) { + vec <- .map2integer64(c(m[i, 1], m[i, 2]), dimtypes[k]) + sbrptr <- libtiledb_subarray_add_range_with_type(sbrptr, k - 1L, dimtypes[k], vec[1], vec[2]) + } + rangeunset <- FALSE } - - if (!is.null(k)) { - if (!is.null(x@selected_ranges[[3]])) { - stop("Cannot set both 'k' and second element of 'selected_ranges'.", call. = FALSE) - } - x@selected_ranges[[3]] <- k + qryptr <- libtiledb_query_set_subarray_object(qryptr, sbrptr) + } + + buflist <- vector(mode = "list", length = length(allnames)) + + # if (!qryinit) { + ## retrieve est_result_size + getEstimatedSize <- function(name, varnum, nullable, qryptr, datatype) { + if (is.na(varnum) && !nullable) { + res <- libtiledb_query_get_est_result_size_var(qryptr, name)[1] + } else if (is.na(varnum) && nullable) { + res <- libtiledb_query_get_est_result_size_var_nullable(qryptr, name)[1] + } else if (!is.na(varnum) && !nullable) { + res <- libtiledb_query_get_est_result_size(qryptr, name) + } else if (!is.na(varnum) && nullable) { + res <- libtiledb_query_get_est_result_size_nullable(qryptr, name)[1] } - ## (i,j,k) are now done and transferred to x@select_ranges - - - ## if ranges selected, use those - for (k in seq_len(length(x@selected_ranges))) { - sbrptr <- libtiledb_subarray(qryptr) - if (is.null(x@selected_ranges[[k]])) { - ##cat("Adding null dim", k, "on", dimtypes[k], "\n") - vec <- .map2integer64(nonemptydom[[k]], dimtypes[k]) - if (vec[1] != 0 && vec[2] != 0) { # corner case of A[] on empty array - sbrptr <- libtiledb_subarray_add_range_with_type(sbrptr, k-1L, dimtypes[k], vec[1], vec[2]) - rangeunset <- FALSE - } - } else if (is.null(nrow(x@selected_ranges[[k]]))) { - ##cat("Adding nrow null dim", k, "on", dimtypes[k], "\n") - vec <- x@selected_ranges[[k]] - vec <- .map2integer64(vec, dimtypes[k]) - sbrptr <- libtiledb_subarray_add_range_with_type(sbrptr, k-1L, dimtypes[k], min(vec), max(vec)) - rangeunset <- FALSE - } else { - ##cat("Adding non-zero dim", k, "on", dimtypes[k], "\n") - m <- x@selected_ranges[[k]] - for (i in seq_len(nrow(m))) { - vec <- .map2integer64(c(m[i,1], m[i,2]), dimtypes[k]) - sbrptr <- libtiledb_subarray_add_range_with_type(sbrptr, k-1L, dimtypes[k], vec[1], vec[2]) - } - rangeunset <- FALSE - } - qryptr <- libtiledb_query_set_subarray_object(qryptr, sbrptr) + if (rangeunset) { + sz <- tiledb_datatype_string_to_sizeof(datatype) + res <- res / sz } - - buflist <- vector(mode="list", length=length(allnames)) - - #if (!qryinit) { - ## retrieve est_result_size - getEstimatedSize <- function(name, varnum, nullable, qryptr, datatype) { - if (is.na(varnum) && !nullable) - res <- libtiledb_query_get_est_result_size_var(qryptr, name)[1] - else if (is.na(varnum) && nullable) - res <- libtiledb_query_get_est_result_size_var_nullable(qryptr, name)[1] - else if (!is.na(varnum) && !nullable) - res <- libtiledb_query_get_est_result_size(qryptr, name) - else if (!is.na(varnum) && nullable) - res <- libtiledb_query_get_est_result_size_nullable(qryptr, name)[1] - if (rangeunset) { - sz <- tiledb_datatype_string_to_sizeof(datatype) - res <- res / sz - } - res - } - ressizes <- mapply(getEstimatedSize, allnames, allvarnum, allnullable, alltypes, - MoreArgs=list(qryptr=qryptr), SIMPLIFY=TRUE) - ## ensure > 0 for correct handling of zero-length outputs, ensure respecting memory budget - resrv <- max(1, min(memory_budget/8, ressizes)) - ## allocate and set buffers - getBuffer <- function(name, type, varnum, nullable, resrv, qryptr, arrptr) { - if (is.na(varnum)) { - if (type %in% c("CHAR", "ASCII", "UTF8")) { - spdl::debug("[getBuffer] '{}' allocating 'char' {} rows given budget of {}", name, resrv, memory_budget) - buf <- libtiledb_query_buffer_var_char_alloc_direct(resrv, memory_budget, nullable) - qryptr <- libtiledb_query_set_buffer_var_char(qryptr, name, buf) - buf - } else { - message("Non-char var.num columns are not currently supported.") - } - } else { - spdl::debug("[getBuffer] '{}' allocating non-char {} rows given budget of {}", name, resrv, memory_budget) - buf <- libtiledb_query_buffer_alloc_ptr(type, resrv, nullable, varnum) - qryptr <- libtiledb_query_set_buffer_ptr(qryptr, name, buf) - buf - } - } - buflist <- mapply(getBuffer, allnames, alltypes, allvarnum, allnullable, - MoreArgs=list(resrv=resrv, qryptr=qryptr, arrptr=arrptr), - SIMPLIFY=FALSE) - - ## if we have a query condition, apply it - if (isTRUE(x@query_condition@init)) { - qryptr <- libtiledb_query_set_condition(qryptr, x@query_condition@ptr) - } - #} - - - res <- list(qryptr, allnames, allvarnum, alltypes, allnullable, buflist) - class(res) <- "batchedquery" res + } + ressizes <- mapply(getEstimatedSize, allnames, allvarnum, allnullable, alltypes, + MoreArgs = list(qryptr = qryptr), SIMPLIFY = TRUE + ) + ## ensure > 0 for correct handling of zero-length outputs, ensure respecting memory budget + resrv <- max(1, min(memory_budget / 8, ressizes)) + ## allocate and set buffers + getBuffer <- function(name, type, varnum, nullable, resrv, qryptr, arrptr) { + if (is.na(varnum)) { + if (type %in% c("CHAR", "ASCII", "UTF8")) { + spdl::debug("[getBuffer] '{}' allocating 'char' {} rows given budget of {}", name, resrv, memory_budget) + buf <- libtiledb_query_buffer_var_char_alloc_direct(resrv, memory_budget, nullable) + qryptr <- libtiledb_query_set_buffer_var_char(qryptr, name, buf) + buf + } else { + message("Non-char var.num columns are not currently supported.") + } + } else { + spdl::debug("[getBuffer] '{}' allocating non-char {} rows given budget of {}", name, resrv, memory_budget) + buf <- libtiledb_query_buffer_alloc_ptr(type, resrv, nullable, varnum) + qryptr <- libtiledb_query_set_buffer_ptr(qryptr, name, buf) + buf + } + } + buflist <- mapply(getBuffer, allnames, alltypes, allvarnum, allnullable, + MoreArgs = list(resrv = resrv, qryptr = qryptr, arrptr = arrptr), + SIMPLIFY = FALSE + ) + + ## if we have a query condition, apply it + if (isTRUE(x@query_condition@init)) { + qryptr <- libtiledb_query_set_condition(qryptr, x@query_condition@ptr) + } + # } + + + res <- list(qryptr, allnames, allvarnum, alltypes, allnullable, buflist) + class(res) <- "batchedquery" + res } @@ -281,99 +288,103 @@ createBatched <- function(x) { #' batched query #' @export fetchBatched <- function(x, obj) { - stopifnot("The 'x' argument must be a 'tiledb_array'" = is(x, "tiledb_array"), - "The 'obj' argument must be 'batchedquery' object" = inherits(obj, "batchedquery")) - qryptr <- obj[[1]] - allnames <- obj[[2]] - allvarnum <- obj[[3]] - alltypes <- obj[[4]] - allnullable <- obj[[5]] - buflist <- obj[[6]] - - asint64 <- x@datetimes_as_int64 - - #verbose <- getOption("verbose", FALSE) - - ## fire off query - qryptr <- libtiledb_query_submit(qryptr) - - ## check status - status <- libtiledb_query_status(qryptr) - ##if (status != "COMPLETE") warning("Query returned '", status, "'.", call. = FALSE) - - ## close array - if (status == "COMPLETE") { - arrptr <- x@ptr - libtiledb_array_close(arrptr) - .pkgenv[["query_status"]] <- status - finished <- TRUE - } - - ## retrieve actual result size (from fixed size element columns) - getResultSize <- function(name, varnum, qryptr) { - if (is.na(varnum)) # symbols come up with higher count - libtiledb_query_result_buffer_elements(qryptr, name, 0) - else - libtiledb_query_result_buffer_elements(qryptr, name) - } - estsz <- mapply(getResultSize, allnames, allvarnum, MoreArgs=list(qryptr=qryptr), SIMPLIFY=TRUE) - spdl::debug("[fetchBatched] estimated result sizes {}", paste(estsz, collapse=",")) - if (any(!is.na(estsz))) { - resrv <- max(estsz, na.rm=TRUE) + stopifnot( + "The 'x' argument must be a 'tiledb_array'" = is(x, "tiledb_array"), + "The 'obj' argument must be 'batchedquery' object" = inherits(obj, "batchedquery") + ) + qryptr <- obj[[1]] + allnames <- obj[[2]] + allvarnum <- obj[[3]] + alltypes <- obj[[4]] + allnullable <- obj[[5]] + buflist <- obj[[6]] + + asint64 <- x@datetimes_as_int64 + + # verbose <- getOption("verbose", FALSE) + + ## fire off query + qryptr <- libtiledb_query_submit(qryptr) + + ## check status + status <- libtiledb_query_status(qryptr) + ## if (status != "COMPLETE") warning("Query returned '", status, "'.", call. = FALSE) + + ## close array + if (status == "COMPLETE") { + arrptr <- x@ptr + libtiledb_array_close(arrptr) + .pkgenv[["query_status"]] <- status + finished <- TRUE + } + + ## retrieve actual result size (from fixed size element columns) + getResultSize <- function(name, varnum, qryptr) { + if (is.na(varnum)) { # symbols come up with higher count + libtiledb_query_result_buffer_elements(qryptr, name, 0) } else { - resrv <- resrv/8 # character case where bytesize of offset vector was used + libtiledb_query_result_buffer_elements(qryptr, name) } - spdl::debug("[fetchBatched] expected size {}", resrv) - ## Permit one pass to allow zero-row schema read - #if (resrv == 0 && counter > 1L) { - #finished <- TRUE - ##if (verbose) message("Breaking loop at zero length expected") - #if (status != "COMPLETE") warning("Query returned '", status, "'.", call. = FALSE) - #.pkgenv[["query_status"]] <- status - #break - #} - ## get results - getResult <- function(buf, name, varnum, estsz, qryptr) { - has_dumpbuffers <- length(x@dumpbuffers) > 0 - if (is.na(varnum)) { - vec <- libtiledb_query_result_buffer_elements_vec(qryptr, name) - if (has_dumpbuffers) { - vlcbuf_to_shmem(x@dumpbuffers, name, buf, vec) - } - libtiledb_query_get_buffer_var_char(buf, vec[1], vec[2])[,1][seq_len(estsz)] - } else { - if (has_dumpbuffers) { - vecbuf_to_shmem(x@dumpbuffers, name, buf, estsz, varnum) - } - libtiledb_query_get_buffer_ptr(buf, asint64)[seq_len(estsz)] - } + } + estsz <- mapply(getResultSize, allnames, allvarnum, MoreArgs = list(qryptr = qryptr), SIMPLIFY = TRUE) + spdl::debug("[fetchBatched] estimated result sizes {}", paste(estsz, collapse = ",")) + if (any(!is.na(estsz))) { + resrv <- max(estsz, na.rm = TRUE) + } else { + resrv <- resrv / 8 # character case where bytesize of offset vector was used + } + spdl::debug("[fetchBatched] expected size {}", resrv) + ## Permit one pass to allow zero-row schema read + # if (resrv == 0 && counter > 1L) { + # finished <- TRUE + ## if (verbose) message("Breaking loop at zero length expected") + # if (status != "COMPLETE") warning("Query returned '", status, "'.", call. = FALSE) + # .pkgenv[["query_status"]] <- status + # break + # } + ## get results + getResult <- function(buf, name, varnum, estsz, qryptr) { + has_dumpbuffers <- length(x@dumpbuffers) > 0 + if (is.na(varnum)) { + vec <- libtiledb_query_result_buffer_elements_vec(qryptr, name) + if (has_dumpbuffers) { + vlcbuf_to_shmem(x@dumpbuffers, name, buf, vec) + } + libtiledb_query_get_buffer_var_char(buf, vec[1], vec[2])[, 1][seq_len(estsz)] + } else { + if (has_dumpbuffers) { + vecbuf_to_shmem(x@dumpbuffers, name, buf, estsz, varnum) + } + libtiledb_query_get_buffer_ptr(buf, asint64)[seq_len(estsz)] } - reslist <- mapply(getResult, buflist, allnames, allvarnum, estsz, - MoreArgs=list(qryptr=qryptr), SIMPLIFY=FALSE) - ## convert list into data.frame (possibly dealing with list columns) and subset - vnum <- 1 # default value of variable number of elements per cell - if (is.list(allvarnum)) allvarnum <- unlist(allvarnum) - if (length(allvarnum) > 0 && any(!is.na(allvarnum))) vnum <- max(allvarnum, na.rm=TRUE) - if (is.finite(vnum) && (vnum > 1)) { - ## turn to list col if a varnum != 1 (and not NA) seen - ind <- which(allvarnum != 1 & !is.na(allvarnum)) - for (k in ind) { - ncells <- allvarnum[k] - v <- reslist[[k]] - ## we split a vector v into 'list-columns' which element containing - ## ncells value (and we get ncells from the Array schema) - ## see https://stackoverflow.com/a/9547594/143305 for I() - ## and https://stackoverflow.com/a/3321659/143305 for split() - reslist[[k]] <- I(unname(split(v, ceiling(seq_along(v)/ncells)))) - } + } + reslist <- mapply(getResult, buflist, allnames, allvarnum, estsz, + MoreArgs = list(qryptr = qryptr), SIMPLIFY = FALSE + ) + ## convert list into data.frame (possibly dealing with list columns) and subset + vnum <- 1 # default value of variable number of elements per cell + if (is.list(allvarnum)) allvarnum <- unlist(allvarnum) + if (length(allvarnum) > 0 && any(!is.na(allvarnum))) vnum <- max(allvarnum, na.rm = TRUE) + if (is.finite(vnum) && (vnum > 1)) { + ## turn to list col if a varnum != 1 (and not NA) seen + ind <- which(allvarnum != 1 & !is.na(allvarnum)) + for (k in ind) { + ncells <- allvarnum[k] + v <- reslist[[k]] + ## we split a vector v into 'list-columns' which element containing + ## ncells value (and we get ncells from the Array schema) + ## see https://stackoverflow.com/a/9547594/143305 for I() + ## and https://stackoverflow.com/a/3321659/143305 for split() + reslist[[k]] <- I(unname(split(v, ceiling(seq_along(v) / ncells)))) } - res <- data.frame(reslist)[seq_len(resrv),,drop=FALSE] - colnames(res) <- allnames - spdl::debug("[fetchBatched] retrieved {}", paste(dim(res), collapse="x")) - ##overallresults[[counter]] <- res - ##counter <- counter + 1L - - res + } + res <- data.frame(reslist)[seq_len(resrv), , drop = FALSE] + colnames(res) <- allnames + spdl::debug("[fetchBatched] retrieved {}", paste(dim(res), collapse = "x")) + ## overallresults[[counter]] <- res + ## counter <- counter + 1L + + res } @@ -388,8 +399,8 @@ fetchBatched <- function(x, obj) { #' @return The Query status as a character variable #' @export statusBatched <- function(obj) { - stopifnot("The 'obj' argument must be 'batchedquery' object" = inherits(obj, "batchedquery")) - libtiledb_query_status(obj[[1]]) + stopifnot("The 'obj' argument must be 'batchedquery' object" = inherits(obj, "batchedquery")) + libtiledb_query_status(obj[[1]]) } #' Check \sQuote{batched} query for completion @@ -403,6 +414,6 @@ statusBatched <- function(obj) { #' @return A logical value to indicated if the query completed #' @export completedBatched <- function(obj) { - stopifnot("The 'obj' argument must be 'batchedquery' object" = inherits(obj, "batchedquery")) - libtiledb_query_status(obj[[1]]) == "COMPLETE" + stopifnot("The 'obj' argument must be 'batchedquery' object" = inherits(obj, "batchedquery")) + libtiledb_query_status(obj[[1]]) == "COMPLETE" } diff --git a/R/Config.R b/R/Config.R index ef7ab5b599..5b4edfef76 100644 --- a/R/Config.R +++ b/R/Config.R @@ -25,12 +25,13 @@ #' @slot ptr An external pointer to the underlying implementation #' @exportClass tiledb_config setClass("tiledb_config", - slots = list(ptr = "externalptr")) + slots = list(ptr = "externalptr") +) #' @importFrom methods new tiledb_config.from_ptr <- function(ptr) { - stopifnot(`ptr must be a non-NULL externalptr to a tiledb_config instance` = !missing(ptr) && is(ptr, "externalptr") && !is.null(ptr)) - new("tiledb_config", ptr = ptr) + stopifnot(`ptr must be a non-NULL externalptr to a tiledb_config instance` = !missing(ptr) && is(ptr, "externalptr") && !is.null(ptr)) + new("tiledb_config", ptr = ptr) } #' Creates a `tiledb_config` object @@ -44,7 +45,9 @@ tiledb_config.from_ptr <- function(ptr) { #' @param config (optional) character vector of config parameter names, values #' @return `tiledb_config` object #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' cfg <- tiledb_config() #' cfg["sm.tile_cache_size"] #' @@ -74,7 +77,9 @@ tiledb_config <- function(config = NA_character_) { #' @param drop Optional logical switch to drop dimensions, default FALSE, currently unused. #' @return a config string value if parameter exists, else NA #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' cfg <- tiledb_config() #' cfg["sm.tile_cache_size"] #' cfg["does_not_exist"] @@ -82,9 +87,11 @@ tiledb_config <- function(config = NA_character_) { #' @aliases [,tiledb_config-method #' @aliases [,tiledb_config,ANY,tiledb_config-method #' @aliases [,tiledb_config,ANY,ANY,tiledb_config-method -setMethod("[", "tiledb_config", function(x, i, j, ..., drop=FALSE) { - stopifnot(`The first subscript in tiledb_config subscript must be of type 'character'` = is.character(i), - `The second subscript is currently unused` = missing(j)) +setMethod("[", "tiledb_config", function(x, i, j, ..., drop = FALSE) { + stopifnot( + `The first subscript in tiledb_config subscript must be of type 'character'` = is.character(i), + `The second subscript is currently unused` = missing(j) + ) tryCatch(libtiledb_config_get(x@ptr, i), error = function(e) NA) }) @@ -96,7 +103,9 @@ setMethod("[", "tiledb_config", function(x, i, j, ..., drop=FALSE) { #' @param value value to set, will be converted into a stringa #' @return updated `tiledb_config` object #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' cfg <- tiledb_config() #' cfg["sm.tile_cache_size"] #' @@ -109,9 +118,11 @@ setMethod("[", "tiledb_config", function(x, i, j, ..., drop=FALSE) { #' @aliases [<-,tiledb_config,ANY,tiledb_config-method #' @aliases [<-,tiledb_config,ANY,ANY,tiledb_config-method setMethod("[<-", "tiledb_config", function(x, i, j, value) { - stopifnot(`The first subscript in tiledb_config subscript must be of type 'character'` = is.character(i), - `The second subscript is currently unused` = missing(j), - `The value argument must be be int, numeric, character or logical` = is.logical(value) || is.character(value) || is.numeric(value)) + stopifnot( + `The first subscript in tiledb_config subscript must be of type 'character'` = is.character(i), + `The second subscript is currently unused` = missing(j), + `The value argument must be be int, numeric, character or logical` = is.logical(value) || is.character(value) || is.numeric(value) + ) if (is.logical(value)) { value <- if (isTRUE(value)) "true" else "false" } else { @@ -125,7 +136,9 @@ setMethod("[<-", "tiledb_config", function(x, i, j, value) { #' #' @param object `tiledb_config` object #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' cfg <- tiledb_config() #' show(cfg) #' @export @@ -139,7 +152,9 @@ setMethod("show", signature(object = "tiledb_config"), function(object) { #' @param path The path to config file to be created #' @return path to created config file #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' tmp <- tempfile() #' cfg <- tiledb_config(c("sm.tile_cache_size" = "10")) #' pth <- tiledb_config_save(cfg, tmp) @@ -148,8 +163,10 @@ setMethod("show", signature(object = "tiledb_config"), function(object) { #' #' @export tiledb_config_save <- function(config, path) { - stopifnot(`The 'config' argument must be a tiledb_config object` = is(config, "tiledb_config"), - `The 'path' argument must be of type character` = is.character(path)) + stopifnot( + `The 'config' argument must be a tiledb_config object` = is(config, "tiledb_config"), + `The 'path' argument must be of type character` = is.character(path) + ) libtiledb_config_save_to_file(config@ptr, path) } @@ -157,7 +174,9 @@ tiledb_config_save <- function(config, path) { #' #' @param path path to the config file #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' tmp <- tempfile() #' cfg <- tiledb_config(c("sm.tile_cache_size" = "10")) #' pth <- tiledb_config_save(cfg, tmp) @@ -177,12 +196,14 @@ tiledb_config_load <- function(path) { #' @param mode Character value `"any"`, currently unused #' @return a character vector of config parameter names, values #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' cfg <- tiledb_config() #' as.vector(cfg) #' #' @export -as.vector.tiledb_config <- function(x, mode="any") { +as.vector.tiledb_config <- function(x, mode = "any") { stopifnot(`The 'x' argument must be a tiledb_config object` = is(x, "tiledb_config")) libtiledb_config_vector(x@ptr) } @@ -223,7 +244,7 @@ as.data.frame.tiledb_config <- function(x, ...) { #' @return The modified configuration object is returned invisibly. #' @importFrom stats na.omit #' @export -limitTileDBCores <- function(ncores, verbose=FALSE) { +limitTileDBCores <- function(ncores, verbose = FALSE) { if (missing(ncores)) { ## start with a simple fallback: 'Ncpus' (if set) or else 2 ncores <- getOption("Ncpus", 2L) @@ -236,7 +257,7 @@ limitTileDBCores <- function(ncores, verbose=FALSE) { cfg <- tiledb_config() cfg["sm.compute_concurrency_level"] <- ncores cfg["sm.io_concurrency_level"] <- ncores - if (verbose) message("Limiting TileDB to ",ncores," cores. See ?limitTileDBCores.") + if (verbose) message("Limiting TileDB to ", ncores, " cores. See ?limitTileDBCores.") invisible(cfg) } @@ -247,8 +268,10 @@ limitTileDBCores <- function(ncores, verbose=FALSE) { #' @return The modified TileDB Config object #' @export tiledb_config_unset <- function(config, param) { - stopifnot(`The 'config' argument must be a tiledb_config object` = is(config, "tiledb_config"), - `The 'param' argument must be of type character` = is.character(param)) + stopifnot( + `The 'config' argument must be a tiledb_config object` = is(config, "tiledb_config"), + `The 'param' argument must be of type character` = is.character(param) + ) libtiledb_config_unset(config@ptr, param) } @@ -257,16 +280,17 @@ tiledb_config_unset <- function(config, param) { #' @return Nothing is returned but as a side-effect the 'AsBuilt' string is displayed #' @export tiledb_config_as_built_show <- function() { - stopifnot("Accessing 'AsBuilt' requires TileDB 2.17 or newer" = tiledb_version(TRUE) >= "2.17.0") - cat(libtiledb_as_built_dump(), "\n") + stopifnot("Accessing 'AsBuilt' requires TileDB 2.17 or newer" = tiledb_version(TRUE) >= "2.17.0") + cat(libtiledb_as_built_dump(), "\n") } #' Return the 'AsBuilt' JSON string #' #' @return The JSON string containing 'AsBuilt' information #' @examples -#' if (tiledb_version(TRUE) > "2.17") -#' txt <- tiledb::tiledb_config_as_built_json() +#' if (tiledb_version(TRUE) > "2.17") { +#' txt <- tiledb::tiledb_config_as_built_json() +#' } #' ## now eg either one of #' ## sapply(jsonlite::fromJSON(txt)$as_built$parameters$storage_backends, \(x) x[[1]]) #' ## sapply(RcppSimdJson::fparse(txt)$as_built$parameters$storage_backends, \(x) x[[1]]) @@ -274,6 +298,6 @@ tiledb_config_as_built_show <- function() { #' ## c(azure = FALSE, gcs = FALSE, hdfs = FALSE, s3 = TRUE) #' @export tiledb_config_as_built_json <- function() { - stopifnot("Accessing 'AsBuilt' requires TileDB 2.17 or newer" = tiledb_version(TRUE) >= "2.17.0") - libtiledb_as_built_dump() + stopifnot("Accessing 'AsBuilt' requires TileDB 2.17 or newer" = tiledb_version(TRUE) >= "2.17.0") + libtiledb_as_built_dump() } diff --git a/R/Ctx.R b/R/Ctx.R index 426475eb72..3765e4befc 100644 --- a/R/Ctx.R +++ b/R/Ctx.R @@ -25,7 +25,8 @@ #' @slot ptr An external pointer to the underlying implementation #' @exportClass tiledb_ctx setClass("tiledb_ctx", - slots = list(ptr = "externalptr")) + slots = list(ptr = "externalptr") +) #' Retrieve a TileDB context object from the package cache #' @@ -37,11 +38,11 @@ tiledb_get_context <- function() { ## if null, create a new context (which caches it too) and return it if (is.null(ctx)) { - ctx <- tiledb_ctx(cached=FALSE) + ctx <- tiledb_ctx(cached = FALSE) ## if we wanted to _globally_ throttle we could do it here ## but as a general rule we do _not_ want to, and prefer ## throttling as an opt in we use in tests only - #cfg <- limitTileDBCores(verbose=TRUE) + # cfg <- limitTileDBCores(verbose=TRUE) } ctx @@ -72,7 +73,9 @@ setContext <- function(ctx) tiledb_set_context(ctx) #' @param cached (optional) logical switch to force new creation #' @return `tiledb_ctx` object #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' # default configuration #' ctx <- tiledb_ctx() #' @@ -83,7 +86,6 @@ setContext <- function(ctx) tiledb_set_context(ctx) #' @importFrom methods is #' @export tiledb_ctx tiledb_ctx <- function(config = NULL, cached = TRUE) { - ctx <- .pkgenv[["ctx"]] ## if not-NULL and no (new) config and cache use is requested, return it @@ -122,17 +124,21 @@ setGeneric("config", function(object, ...) { #' @param object tiledb_ctx object #' @return `tiledb_config` object associated with the `tiledb_ctx` instance #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' ctx <- tiledb_ctx(c("sm.tile_cache_size" = "10")) #' cfg <- config(ctx) #' cfg["sm.tile_cache_size"] #' #' @export -setMethod("config", signature(object = "tiledb_ctx"), - function(object = tiledb_get_context()) { - ptr <- libtiledb_ctx_config(object@ptr) - tiledb_config.from_ptr(ptr) - }) +setMethod( + "config", signature(object = "tiledb_ctx"), + function(object = tiledb_get_context()) { + ptr <- libtiledb_ctx_config(object@ptr) + tiledb_config.from_ptr(ptr) + } +) #' Query if a TileDB backend is supported #' @@ -147,14 +153,18 @@ setMethod("config", signature(object = "tiledb_ctx"), #' @param scheme URI string scheme ("file", "hdfs", "s3") #' @return TRUE if tiledb backend is supported, FALSE otherwise #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' tiledb_is_supported_fs("file") #' tiledb_is_supported_fs("s3") #' #' @export tiledb_is_supported_fs <- function(scheme, object = tiledb_get_context()) { - stopifnot(`The 'object' argument must be a tiledb_ctx object` = is(object, "tiledb_ctx"), - `The 'scheme' argument must be of type character` = is.character(scheme)) + stopifnot( + `The 'object' argument must be a tiledb_ctx object` = is(object, "tiledb_ctx"), + `The 'scheme' argument must be of type character` = is.character(scheme) + ) libtiledb_ctx_is_supported_fs(object@ptr, scheme) } @@ -164,15 +174,19 @@ tiledb_is_supported_fs <- function(scheme, object = tiledb_get_context()) { #' @param key string #' @param value string #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' ctx <- tiledb_ctx(c("sm.tile_cache_size" = "10")) #' cfg <- tiledb_ctx_set_tag(ctx, "tag", "value") #' #' @export tiledb_ctx_set_tag <- function(object, key, value) { - stopifnot(`The 'object' argument must be a tiledb_ctx object` = is(object, "tiledb_ctx"), - `The 'key' argument must be of type character` = is.character(key), - `The 'value' argument must be of type character` = is.character(key)) + stopifnot( + `The 'object' argument must be a tiledb_ctx object` = is(object, "tiledb_ctx"), + `The 'key' argument must be of type character` = is.character(key), + `The 'value' argument must be of type character` = is.character(key) + ) return(libtiledb_ctx_set_tag(object@ptr, key, value)) } @@ -185,7 +199,7 @@ tiledb_ctx_set_default_tags <- function(object) { tiledb_ctx_set_tag(object, "x-tiledb-api-language", "r") tiledb_ctx_set_tag(object, "x-tiledb-api-language-version", as.character(packageVersion("tiledb"))) info <- Sys.info() - tiledb_ctx_set_tag(object, "x-tiledb-api-sys-platform", paste(info["sysname"], info["release"], info["machine"], collapse="")) + tiledb_ctx_set_tag(object, "x-tiledb-api-sys-platform", paste(info["sysname"], info["release"], info["machine"], collapse = "")) } #' Return context statistics as a JSON string @@ -194,6 +208,6 @@ tiledb_ctx_set_default_tags <- function(object) { #' @return A JSON-formatted string with context statistics #' @export tiledb_ctx_stats <- function(object = tiledb_get_context()) { - stopifnot(`The 'object' variable must be a TileDB Context object` = is(object, "tiledb_ctx")) - libtiledb_ctx_stats(object@ptr) + stopifnot(`The 'object' variable must be a TileDB Context object` = is(object, "tiledb_ctx")) + libtiledb_ctx_stats(object@ptr) } diff --git a/R/CurrentDomain.R b/R/CurrentDomain.R index c5da4e63c5..a617219b5a 100644 --- a/R/CurrentDomain.R +++ b/R/CurrentDomain.R @@ -25,24 +25,29 @@ #' @slot ptr An external pointer to the underlying CurrentDomain object #' @exportClass tiledb_current_domain setClass("tiledb_current_domain", - slots = list(ptr = "externalptr")) + slots = list(ptr = "externalptr") +) #' Creates a `tiledb_current_domain` object #' #' @param ctx (optional) A TileDB Ctx object #' @return The `tiledb_current_domain` object #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' if (tiledb_version(TRUE) >= "2.25.0") { -#' cd <-tiledb_current_domain() +#' cd <- tiledb_current_domain() #' } #' #' @export tiledb_current_domain <- function(ctx = tiledb_get_context()) { - stopifnot("The first argment must be a TileDB Ctx object" = is(ctx, "tiledb_ctx"), - "This function needs TileDB 2.25.0 or later" = tiledb_version(TRUE) >= "2.25.0") - ptr <- libtiledb_current_domain_create(ctx@ptr) - return(new("tiledb_current_domain", ptr = ptr)) + stopifnot( + "The first argment must be a TileDB Ctx object" = is(ctx, "tiledb_ctx"), + "This function needs TileDB 2.25.0 or later" = tiledb_version(TRUE) >= "2.25.0" + ) + ptr <- libtiledb_current_domain_create(ctx@ptr) + return(new("tiledb_current_domain", ptr = ptr)) } #' Get `tiledb_current_domain` data type as string @@ -51,10 +56,12 @@ tiledb_current_domain <- function(ctx = tiledb_get_context()) { #' @return The datatype (as string) of the `tiledb_current_domain` object #' @export tiledb_current_domain_get_type <- function(cd) { - stopifnot("The first argment must be a TileDB CurrentDomain object" = - is(cd, "tiledb_current_domain"), - "This function needs TileDB 2.25.0 or later" = tiledb_version(TRUE) >= "2.25.0") - libtiledb_current_domain_type(cd@ptr) + stopifnot( + "The first argment must be a TileDB CurrentDomain object" = + is(cd, "tiledb_current_domain"), + "This function needs TileDB 2.25.0 or later" = tiledb_version(TRUE) >= "2.25.0" + ) + libtiledb_current_domain_type(cd@ptr) } #' Set a `tiledb_ndrectangle` in a `tiledb_current_domain` object @@ -64,12 +71,14 @@ tiledb_current_domain_get_type <- function(cd) { #' @return The modifiled TileDB CurrendDomain object #' @export tiledb_current_domain_set_ndrectangle <- function(cd, ndr) { - stopifnot("The first argment must be a TileDB CurrentDomain object" = - is(cd, "tiledb_current_domain"), - "The second argument must be a TileDB NDRectangle object" = is(ndr, "tiledb_ndrectangle"), - "This function needs TileDB 2.25.0 or later" = tiledb_version(TRUE) >= "2.25.0") - cd@ptr <- libtiledb_current_domain_set_ndrectangle(cd@ptr, ndr@ptr) - cd + stopifnot( + "The first argment must be a TileDB CurrentDomain object" = + is(cd, "tiledb_current_domain"), + "The second argument must be a TileDB NDRectangle object" = is(ndr, "tiledb_ndrectangle"), + "This function needs TileDB 2.25.0 or later" = tiledb_version(TRUE) >= "2.25.0" + ) + cd@ptr <- libtiledb_current_domain_set_ndrectangle(cd@ptr, ndr@ptr) + cd } #' Get a `tiledb_ndrectangle` from a `tiledb_current_domain` object @@ -78,11 +87,13 @@ tiledb_current_domain_set_ndrectangle <- function(cd, ndr) { #' @return The corresponding TileDB NDRectangle object #' @export tiledb_current_domain_get_ndrectangle <- function(cd) { - stopifnot("The first argment must be a TileDB CurrentDomain object" = - is(cd, "tiledb_current_domain"), - "This function needs TileDB 2.25.0 or later" = tiledb_version(TRUE) >= "2.25.0") - ptr <- libtiledb_current_domain_get_ndrectangle(cd@ptr) - return(new("tiledb_ndrectangle", ptr = ptr)) + stopifnot( + "The first argment must be a TileDB CurrentDomain object" = + is(cd, "tiledb_current_domain"), + "This function needs TileDB 2.25.0 or later" = tiledb_version(TRUE) >= "2.25.0" + ) + ptr <- libtiledb_current_domain_get_ndrectangle(cd@ptr) + return(new("tiledb_ndrectangle", ptr = ptr)) } #' Test `tiledb_current_domain` object for being empty @@ -91,8 +102,10 @@ tiledb_current_domain_get_ndrectangle <- function(cd) { #' @return A boolean indicating whether the object is empty or not #' @export tiledb_current_domain_is_empty <- function(cd) { - stopifnot("The first argment must be a TileDB CurrentDomain object" = - is(cd, "tiledb_current_domain"), - "This function needs TileDB 2.25.0 or later" = tiledb_version(TRUE) >= "2.25.0") - libtiledb_current_domain_is_empty(cd@ptr) + stopifnot( + "The first argment must be a TileDB CurrentDomain object" = + is(cd, "tiledb_current_domain"), + "This function needs TileDB 2.25.0 or later" = tiledb_version(TRUE) >= "2.25.0" + ) + libtiledb_current_domain_is_empty(cd@ptr) } diff --git a/R/DataFrame.R b/R/DataFrame.R index cef973d4b4..c443385b5c 100644 --- a/R/DataFrame.R +++ b/R/DataFrame.R @@ -82,226 +82,252 @@ ##' all.equal(iris, newdf, check.attributes=FALSE) # extra attribute on query in newdf ##' all.equal(as.matrix(iris), as.matrix(newdf)) # also strips attribute ##' @export -fromDataFrame <- function(obj, uri, col_index=NULL, sparse=TRUE, allows_dups=sparse, - cell_order = "COL_MAJOR", tile_order = "COL_MAJOR", filter="ZSTD", - capacity = 10000L, tile_domain = NULL, tile_extent = NULL, - mode = c("ingest", "schema_only", "append"), filter_list = NULL, - coords_filters = "ZSTD", offsets_filters = "ZSTD", - validity_filters = "RLE", debug = FALSE, - timestamps = as.POSIXct(double(), origin="1970-01-01")) { +fromDataFrame <- function( + obj, + uri, + col_index = NULL, + sparse = TRUE, + allows_dups = sparse, + cell_order = "COL_MAJOR", + tile_order = "COL_MAJOR", + filter = "ZSTD", + capacity = 10000L, + tile_domain = NULL, + tile_extent = NULL, + mode = c("ingest", "schema_only", "append"), + filter_list = NULL, + coords_filters = "ZSTD", + offsets_filters = "ZSTD", + validity_filters = "RLE", + debug = FALSE, + timestamps = as.POSIXct(double(), origin = "1970-01-01") +) { + stopifnot( + "Argument 'obj' should be a 'data.frame' (or a related object)" = inherits(obj, "data.frame"), + "Argument 'uri' should be a character variable" = is.character(uri), + "Argument 'timestamps' must be a POSIXct vector" = inherits(timestamps, "POSIXct"), + "Argument 'timestamps' must be 0, 1 or 2 values" = length(timestamps) %in% c(0L, 1L, 2L) + ) + if (!is.null(col_index) && is.character(col_index)) col_index <- match(col_index, colnames(obj)) + dims <- dim(obj) + mode <- match.arg(mode) - stopifnot("Argument 'obj' should be a 'data.frame' (or a related object)" = inherits(obj, "data.frame"), - "Argument 'uri' should be a character variable" = is.character(uri), - "Argument 'timestamps' must be a POSIXct vector" = inherits(timestamps, "POSIXct"), - "Argument 'timestamps' must be 0, 1 or 2 values" = length(timestamps) %in% c(0L, 1L, 2L)) - if (!is.null(col_index) && is.character(col_index)) col_index <- match(col_index, colnames(obj)) - dims <- dim(obj) - mode <- match.arg(mode) + if (class(obj)[1] != "data.frame") obj <- as.data.frame(obj) - if (class(obj)[1] != "data.frame") obj <- as.data.frame(obj) - - ## turn factor columns in char columns - ## TODO: add an option - if (tiledb_version(TRUE) < "2.17.0") { - factcols <- grep("factor", sapply(obj, class)) - if (length(factcols) > 0) { - for (i in factcols) obj[,i] <- as.character(obj[,i]) - } + ## turn factor columns in char columns + ## TODO: add an option + if (tiledb_version(TRUE) < "2.17.0") { + factcols <- grep("factor", sapply(obj, class)) + if (length(factcols) > 0) { + for (i in factcols) obj[, i] <- as.character(obj[, i]) } + } - ## Create default filter_list from filter vector, 'NONE' and 'ZSTD' is default - default_filter_list <- tiledb_filter_list(sapply(filter, tiledb_filter)) + ## Create default filter_list from filter vector, 'NONE' and 'ZSTD' is default + default_filter_list <- tiledb_filter_list(sapply(filter, tiledb_filter)) - if (is.null(col_index)) { - if (missing(tile_domain)) tile_domain <- c(1L, dims[1]) - if (missing(tile_extent)) tile_extent <- dims[1] + if (is.null(col_index)) { + if (missing(tile_domain)) tile_domain <- c(1L, dims[1]) + if (missing(tile_extent)) tile_extent <- dims[1] - dom <- tiledb_domain(dims = tiledb_dim(name = "__tiledb_rows", - domain = tile_domain, - tile = tile_extent, - type = "INT32")) - useobj <- obj + dom <- tiledb_domain(dims = tiledb_dim( + name = "__tiledb_rows", + domain = tile_domain, + tile = tile_extent, + type = "INT32" + )) + useobj <- obj + } else { + dimobj <- obj[, col_index, drop = FALSE] + atrobj <- obj[, -col_index, drop = FALSE] + useobj <- cbind(dimobj, atrobj) - } else { - - dimobj <- obj[, col_index, drop=FALSE] - atrobj <- obj[, -col_index, drop=FALSE] - useobj <- cbind(dimobj, atrobj) + if (any(is.na(dimobj))) { + stop("Nullable columns are not supported as dimension columns.", call. = FALSE) + } - if (any(is.na(dimobj))) - stop("Nullable columns are not supported as dimension columns.", call. = FALSE) + makeDim <- function(ind) { + idxcol <- dimobj[, ind] + idxnam <- colnames(dimobj)[ind] + if (inherits(idxcol, "factor")) idxcol <- as.character(idxcol) + col_domain <- if (is.null(tile_domain)) { # default case + c(min(idxcol), max(idxcol)) # use range + } else if (is.list(tile_domain)) { # but if list + if (idxnam %in% names(tile_domain)) { # and name exists + tile_domain[[idxnam]] # use element + } else { + c(min(idxcol), max(idxcol)) # else fallback + } + } else { # else + tile_domain # use non-list value + } + col_extent <- if (is.null(tile_extent)) dims[1] else tile_extent + if (!inherits(idxcol, "character")) { + dom_range <- diff(as.numeric(range(col_domain))) + 1 + col_extent <- min(dom_range, col_extent) + } + dtype <- "INT32" # default + if (inherits(idxcol, "POSIXt")) { + dtype <- "DATETIME_US" + col_domain <- as.numeric(col_domain) * 1e6 # int64 used + } else if (inherits(idxcol, "Date")) { + dtype <- "DATETIME_DAY" + col_extent <- as.numeric(col_extent) # to not trigger INT32 test + } else if (inherits(idxcol, "numeric")) { + dtype <- "FLOAT64" + col_extent <- as.numeric(col_extent) + } else if (inherits(idxcol, "nanotime")) { + dtype <- "DATETIME_NS" + col_domain <- c(min(idxcol) - 1e10, max(idxcol) + 1e10) + } else if (inherits(idxcol, "integer64")) { + dtype <- "INT64" + col_extent <- bit64::as.integer64(col_extent) + } else if (inherits(idxcol, "character")) { + dtype <- "ASCII" + col_extent <- NULL + col_domain <- c(NULL, NULL) + } else if (dtype == "INT32") { + col_extent <- as.integer(col_extent) + } - makeDim <- function(ind) { - idxcol <- dimobj[,ind] - idxnam <- colnames(dimobj)[ind] - if (inherits(idxcol, "factor")) idxcol <- as.character(idxcol) - col_domain <- if (is.null(tile_domain)) { # default case - c(min(idxcol), max(idxcol)) # use range - } else if (is.list(tile_domain)) { # but if list - if (idxnam %in% names(tile_domain)) { # and name exists - tile_domain[[idxnam]] # use element - } else { - c(min(idxcol), max(idxcol)) # else fallback - } - } else { # else - tile_domain # use non-list value - } - col_extent <- if (is.null(tile_extent)) dims[1] else tile_extent - if (!inherits(idxcol, "character")) { - dom_range <- diff(as.numeric(range(col_domain))) + 1 - col_extent <- min(dom_range, col_extent) - } - dtype <- "INT32" # default - if (inherits(idxcol, "POSIXt")) { - dtype <- "DATETIME_US" - col_domain <- as.numeric(col_domain) * 1e6 # int64 used - } else if (inherits(idxcol, "Date")) { - dtype <- "DATETIME_DAY" - col_extent <- as.numeric(col_extent) # to not trigger INT32 test - } else if (inherits(idxcol, "numeric")) { - dtype <- "FLOAT64" - col_extent <- as.numeric(col_extent) - } else if (inherits(idxcol, "nanotime")) { - dtype <- "DATETIME_NS" - col_domain <- c(min(idxcol) - 1e10, max(idxcol) + 1e10) - } else if (inherits(idxcol, "integer64")) { - dtype <- "INT64" - col_extent <- bit64::as.integer64(col_extent) - } else if (inherits(idxcol, "character")) { - dtype <- "ASCII" - col_extent <- NULL - col_domain <- c(NULL, NULL) - } else if (dtype == "INT32") { - col_extent <- as.integer(col_extent) - } + if (debug) { + cat(sprintf( + "Setting domain name %s type %s domain (%s,%s) extent %s\n", idxnam, dtype, + ifelse(is.null(col_domain[1]), "null", format(col_domain[1])), + ifelse(is.null(col_domain[2]), "null", format(col_domain[2])), + ifelse(is.null(col_extent), "null", format(col_extent)) + )) + } - if (debug) { - cat(sprintf("Setting domain name %s type %s domain (%s,%s) extent %s\n", idxnam, dtype, - ifelse(is.null(col_domain[1]), "null", format(col_domain[1])), - ifelse(is.null(col_domain[2]), "null", format(col_domain[2])), - ifelse(is.null(col_extent), "null", format(col_extent)))) - } + d <- tiledb_dim( + name = idxnam, + domain = col_domain, + tile = col_extent, + type = dtype + ) - d <- tiledb_dim(name = idxnam, - domain = col_domain, - tile = col_extent, - type = dtype) + if (idxnam %in% names(filter_list)) { + filter_list(d) <- tiledb_filter_list(sapply(filter_list[[idxnam]], tiledb_filter)) + } - if (idxnam %in% names(filter_list)) { - filter_list(d) <- tiledb_filter_list(sapply(filter_list[[idxnam]], tiledb_filter)) - } + d + } + dimensions <- sapply(seq_len(ncol(dimobj)), makeDim) - d - } - dimensions <- sapply(seq_len(ncol(dimobj)), makeDim) + dom <- tiledb_domain(dims = dimensions) + } - dom <- tiledb_domain(dims = dimensions) + ## the simple helper function used create attribute_i given index i + ## we now make it a little bit more powerful yet clumsy but returning a + ## three element list at each element where the list contains the attribute + ## along with the optional factor levels vector (and the corresponding column name) + makeAttr <- function(ind) { + col <- obj[, ind] + colname <- colnames(obj)[ind] + lvls <- NULL # by default no factor levels + ordrd <- FALSE + if (inherits(col, "AsIs")) { + ## we just look at the first list column, others have to have same type and length + cl <- class(obj[, ind][[1]]) + nc <- length(obj[, ind][[1]]) + } else { + cl <- class(col)[1] + nc <- 1 + } + if (cl == "integer") { + tp <- "INT32" + } else if (cl == "numeric") { + tp <- "FLOAT64" + } else if (cl == "character") { + tp <- "ASCII" + } else if (cl == "Date") { + tp <- "DATETIME_DAY" + } else if (cl == "POSIXct" || cl == "POSIXlt") { + tp <- "DATETIME_MS" + } else if (cl == "nanotime") { + tp <- "DATETIME_NS" + } else if (cl == "integer64") { + tp <- "INT64" + } else if (cl == "logical") { + tp <- if (tiledb_version(TRUE) >= "2.10.0") "BOOL" else "INT32" + } else if (cl == "factor" || cl == "ordered") { + lvls <- levels(col) # extract factor levels + if (length(lvls) > .Machine$integer.max) { + stop("Cannot represent this many levels for ", colname, call. = FALSE) + } + attr(lvls, "ordered") <- cl == "ordered" + tp <- "INT32" + } else { + stop("Currently unsupported type: ", cl) } - ## the simple helper function used create attribute_i given index i - ## we now make it a little bit more powerful yet clumsy but returning a - ## three element list at each element where the list contains the attribute - ## along with the optional factor levels vector (and the corresponding column name) - makeAttr <- function(ind) { - col <- obj[,ind] - colname <- colnames(obj)[ind] - lvls <- NULL # by default no factor levels - ordrd <- FALSE - if (inherits(col, "AsIs")) { - ## we just look at the first list column, others have to have same type and length - cl <- class(obj[,ind][[1]]) - nc <- length(obj[,ind][[1]]) - } else { - cl <- class(col)[1] - nc <- 1 - } - if (cl == "integer") - tp <- "INT32" - else if (cl == "numeric") - tp <- "FLOAT64" - else if (cl == "character") - tp <- "ASCII" - else if (cl == "Date") - tp <- "DATETIME_DAY" - else if (cl == "POSIXct" || cl == "POSIXlt") - tp <- "DATETIME_MS" - else if (cl == "nanotime") - tp <- "DATETIME_NS" - else if (cl == "integer64") - tp <- "INT64" - else if (cl == "logical") - tp <- if (tiledb_version(TRUE) >= "2.10.0") "BOOL" else "INT32" - else if (cl == "factor" || cl == "ordered") { - lvls <- levels(col) # extract factor levels - if (length(lvls) > .Machine$integer.max) - stop("Cannot represent this many levels for ", colname, call. = FALSE) - attr(lvls, "ordered") <- cl == "ordered" - tp <- "INT32" - } - else - stop("Currently unsupported type: ", cl) - - filters <- if (colname %in% names(filter_list)) { - tiledb_filter_list(sapply(filter_list[[colname]], tiledb_filter)) - } else { - default_filter_list - } - if (debug) { - cat(sprintf("Setting attribute name %s type %s\n", colname, tp)) - } - attr <- tiledb_attr(colname, - type = tp, - ncells = if (tp %in% c("CHAR","ASCII")) NA_integer_ else nc, - filter_list = filters, - nullable = any(is.na(col)), - enumeration = lvls) - list(attr=attr, lvls=lvls, name=colname) # return a list of three with levels and names + filters <- if (colname %in% names(filter_list)) { + tiledb_filter_list(sapply(filter_list[[colname]], tiledb_filter)) + } else { + default_filter_list } - cols <- seq_len(dims[2]) - if (!is.null(col_index)) cols <- cols[-col_index] - attributes <- enumerations <- list() # fallback - if (length(cols) > 0) { - a_e <- lapply(cols, makeAttr) - attributes <- lapply(a_e, "[[", 1) # get attributes from list - enumerations <- lapply(a_e, "[[", 2) # get enumeration levels (with 'ordered' attribute) - colnames <- lapply(a_e, "[[", 3) # get column names - names(enumerations) <- colnames + if (debug) { + cat(sprintf("Setting attribute name %s type %s\n", colname, tp)) } - schema <- tiledb_array_schema(dom, - attrs = attributes, - cell_order = cell_order, - tile_order = tile_order, - sparse=sparse, - coords_filter_list = tiledb_filter_list(sapply(coords_filters, tiledb_filter)), - offsets_filter_list = tiledb_filter_list(sapply(offsets_filters, tiledb_filter)), - validity_filter_list = tiledb_filter_list(sapply(validity_filters, tiledb_filter)), - capacity = capacity, - enumerations = if (length(enumerations) > 0) enumerations else NULL) - allows_dups(schema) <- allows_dups + attr <- tiledb_attr(colname, + type = tp, + ncells = if (tp %in% c("CHAR", "ASCII")) NA_integer_ else nc, + filter_list = filters, + nullable = any(is.na(col)), + enumeration = lvls + ) + list(attr = attr, lvls = lvls, name = colname) # return a list of three with levels and names + } + cols <- seq_len(dims[2]) + if (!is.null(col_index)) cols <- cols[-col_index] + attributes <- enumerations <- list() # fallback + if (length(cols) > 0) { + a_e <- lapply(cols, makeAttr) + attributes <- lapply(a_e, "[[", 1) # get attributes from list + enumerations <- lapply(a_e, "[[", 2) # get enumeration levels (with 'ordered' attribute) + colnames <- lapply(a_e, "[[", 3) # get column names + names(enumerations) <- colnames + } + schema <- tiledb_array_schema(dom, + attrs = attributes, + cell_order = cell_order, + tile_order = tile_order, + sparse = sparse, + coords_filter_list = tiledb_filter_list(sapply(coords_filters, tiledb_filter)), + offsets_filter_list = tiledb_filter_list(sapply(offsets_filters, tiledb_filter)), + validity_filter_list = tiledb_filter_list(sapply(validity_filters, tiledb_filter)), + capacity = capacity, + enumerations = if (length(enumerations) > 0) enumerations else NULL + ) + allows_dups(schema) <- allows_dups - if (mode != "append") - tiledb_array_create(uri, schema) + if (mode != "append") { + tiledb_array_create(uri, schema) + } - if (mode != "schema_only") { - df <- switch(length(timestamps) + 1, # switch takes ints starting at one - tiledb_array(uri, query_type = "WRITE"), - tiledb_array(uri, query_type = "WRITE", timestamp_end=timestamps[1]), - tiledb_array(uri, query_type = "WRITE", timestamp_start=timestamps[1], timestamp_end=timestamps[2])) - ## when setting an index when likely want 'sparse write to dense array - if (!is.null(col_index) && !sparse) - query_layout(df) <- "UNORDERED" - if (is.null(col_index) && sparse) - useobj <- cbind(data.frame(`__tiledb_rows`=seq(1,dims[1]), check.names=FALSE), useobj) - df[] <- useobj + if (mode != "schema_only") { + df <- switch(length(timestamps) + 1, # switch takes ints starting at one + tiledb_array(uri, query_type = "WRITE"), + tiledb_array(uri, query_type = "WRITE", timestamp_end = timestamps[1]), + tiledb_array(uri, query_type = "WRITE", timestamp_start = timestamps[1], timestamp_end = timestamps[2]) + ) + ## when setting an index when likely want 'sparse write to dense array + if (!is.null(col_index) && !sparse) { + query_layout(df) <- "UNORDERED" + } + if (is.null(col_index) && sparse) { + useobj <- cbind(data.frame(`__tiledb_rows` = seq(1, dims[1]), check.names = FALSE), useobj) } - invisible(NULL) + df[] <- useobj + } + invisible(NULL) } .testFromDataFrame <- function(obj, uri) { - if (dir.exists(uri)) unlink(uri, recursive=TRUE) + if (dir.exists(uri)) unlink(uri, recursive = TRUE) fromDataFrame(obj, uri) - df <- tiledb_array(uri, return_as="data.frame") + df <- tiledb_array(uri, return_as = "data.frame") df[] } @@ -324,11 +350,11 @@ fromDataFrame <- function(obj, uri, col_index=NULL, sparse=TRUE, allows_dups=spa }) if (dir.exists(uri)) { message("Removing existing directory ", uri) - unlink(uri, recursive=TRUE) + unlink(uri, recursive = TRUE) } fromDataFrame(bkdf, uri) - arr <- tiledb_array(uri, return_as="data.frame") + arr <- tiledb_array(uri, return_as = "data.frame") newdf <- arr[] invisible(newdf) } @@ -336,12 +362,12 @@ fromDataFrame <- function(obj, uri, col_index=NULL, sparse=TRUE, allows_dups=spa .testWithNanotime <- function(df, uri) { if (dir.exists(uri)) { message("Removing existing directory ", uri) - unlink(uri, recursive=TRUE) + unlink(uri, recursive = TRUE) } fromDataFrame(df, uri) cat("Data written\n") - arr <- tiledb_array(uri, return_as="data.frame") + arr <- tiledb_array(uri, return_as = "data.frame") newdf <- arr[] invisible(newdf) } diff --git a/R/Dim.R b/R/Dim.R index b9d218473f..a666469b97 100644 --- a/R/Dim.R +++ b/R/Dim.R @@ -25,7 +25,8 @@ #' @slot ptr An external pointer to the underlying implementation #' @exportClass tiledb_dim setClass("tiledb_dim", - slots = list(ptr = "externalptr")) + slots = list(ptr = "externalptr") +) #' @importFrom methods new tiledb_dim.from_ptr <- function(ptr) { @@ -47,88 +48,107 @@ tiledb_dim.from_ptr <- function(ptr) { #' @param ctx tiledb_ctx object (optional) #' @return `tiledb_dim` object #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' tiledb_dim(name = "d1", domain = c(1L, 10L), tile = 5L, type = "INT32") #' #' @importFrom methods new #' @export tiledb_dim -tiledb_dim <- function(name, domain, tile, type, - filter_list = tiledb_filter_list(), ctx = tiledb_get_context()) { - stopifnot("Argument 'name' must be supplied when creating a dimension object" = !missing(name), - "Argument 'name' must be a scalar string when creating a dimension object" = is.scalar(name, "character"), - "Argument 'ctx' must be a tiledb_ctx object" = is(ctx, "tiledb_ctx")) - if (missing(type)) { - type <- ifelse(is.integer(domain), "INT32", "FLOAT64") - } else if (!type %in% c("INT8", "INT16", "INT32", "INT64", - "UINT8", "UINT16", "UINT32", "UINT64", - "FLOAT32", "FLOAT64", - "DATETIME_YEAR","DATETIME_MONTH","DATETIME_WEEK","DATETIME_DAY", - "DATETIME_HR", "DATETIME_MIN", "DATETIME_SEC", - "DATETIME_MS", "DATETIME_US", "DATETIME_NS", - "DATETIME_PS", "DATETIME_FS", "DATETIME_AS", - "ASCII")) { - stop("type argument must be '(U)INT{8,16,32,64}', 'FLOAT{32,64}', 'ASCII', or a supported 'DATETIME_*' type.", call.=FALSE) - } +tiledb_dim <- function( + name, + domain, + tile, + type, + filter_list = tiledb_filter_list(), + ctx = tiledb_get_context() +) { + stopifnot( + "Argument 'name' must be supplied when creating a dimension object" = !missing(name), + "Argument 'name' must be a scalar string when creating a dimension object" = is.scalar(name, "character"), + "Argument 'ctx' must be a tiledb_ctx object" = is(ctx, "tiledb_ctx") + ) + if (missing(type)) { + type <- ifelse(is.integer(domain), "INT32", "FLOAT64") + } else if (!type %in% c( + "INT8", "INT16", "INT32", "INT64", + "UINT8", "UINT16", "UINT32", "UINT64", + "FLOAT32", "FLOAT64", + "DATETIME_YEAR", "DATETIME_MONTH", "DATETIME_WEEK", "DATETIME_DAY", + "DATETIME_HR", "DATETIME_MIN", "DATETIME_SEC", + "DATETIME_MS", "DATETIME_US", "DATETIME_NS", + "DATETIME_PS", "DATETIME_FS", "DATETIME_AS", + "ASCII" + )) { + stop("type argument must be '(U)INT{8,16,32,64}', 'FLOAT{32,64}', 'ASCII', or a supported 'DATETIME_*' type.", call. = FALSE) + } - if (!type %in% c("ASCII")) { - if ((typeof(domain) != "integer" && typeof(domain) != "double") || (length(domain) != 2)) { - stop("The 'domain' argument must be an integer or double vector of length 2") - } + if (!type %in% c("ASCII")) { + if ((typeof(domain) != "integer" && typeof(domain) != "double") || (length(domain) != 2)) { + stop("The 'domain' argument must be an integer or double vector of length 2") } + } - ## if type is (U)INT64 then convert domain and tile arguments so - ## that users are not forced to submit as int64 - if (type %in% c("INT64", "UINT64")) { - if (!inherits(domain, "integer64")) { - domain <- bit64::as.integer64(domain) - } - if (!inherits(tile, "integer64")) { - tile <- bit64::as.integer64(domain) - } + ## if type is (U)INT64 then convert domain and tile arguments so + ## that users are not forced to submit as int64 + if (type %in% c("INT64", "UINT64")) { + if (!inherits(domain, "integer64")) { + domain <- bit64::as.integer64(domain) } - - if (inherits(domain, "nanotime") || # not integer64 as we want the conversion only for datetimes - type %in% c("DATETIME_PS", # but also for high precision times we cannot fit into NS - "DATETIME_FS", - "DATETIME_AS")) { - w <- getOption("warn") # store warning levels - options("warn" = -1) # suppress warnings - domain <- as.numeric(domain) # for this lossy conversion - options("warn" = w) # restore warning levels + if (!inherits(tile, "integer64")) { + tile <- bit64::as.integer64(domain) } + } - ## by default, tile extent should span the whole domain - if (missing(tile)) { - if (is.integer(domain)) { - tile <- (domain[2L] - domain[1L]) + 1L - } else { - tile <- (domain[2L] - domain[1L]) - } + if (inherits(domain, "nanotime") || # not integer64 as we want the conversion only for datetimes + type %in% c( + "DATETIME_PS", # but also for high precision times we cannot fit into NS + "DATETIME_FS", + "DATETIME_AS" + )) { + w <- getOption("warn") # store warning levels + options("warn" = -1) # suppress warnings + domain <- as.numeric(domain) # for this lossy conversion + options("warn" = w) # restore warning levels + } + + ## by default, tile extent should span the whole domain + if (missing(tile)) { + if (is.integer(domain)) { + tile <- (domain[2L] - domain[1L]) + 1L + } else { + tile <- (domain[2L] - domain[1L]) } - ptr <- libtiledb_dim(ctx@ptr, name, type, domain, tile) - libtiledb_dimension_set_filter_list(ptr, filter_list@ptr) - return(new("tiledb_dim", ptr = ptr)) + } + ptr <- libtiledb_dim(ctx@ptr, name, type, domain, tile) + libtiledb_dimension_set_filter_list(ptr, filter_list@ptr) + return(new("tiledb_dim", ptr = ptr)) } # internal function returning text use here and in other higher-level show() methods .as_text_dimension <- function(object) { - cells <- cell_val_num(object) - fl <- filter_list(object) - nf <- nfilters(fl) - tp <- datatype(object) - dm <- if (is.na(cells)) "" else paste0(domain(object), if (grepl("INT", tp)) "L" else "", collape="") - ex <- if (is.na(cells)) "" else paste0(tile(object), if (grepl("INT", tp)) "L" else "", collape="") - txt <- paste0("tiledb_dim(name=\"", name(object), "\", ", - "domain=c(", if (is.na(cells)) "NULL,NULL" - else paste0(dm, collapse=","), "), ", - "tile=", if (is.na(cells)) "NULL" else ex, ", ", - "type=\"", datatype(object), "\"", - if (nf == 0) ")" else ", ") - if (nf > 0) { - txt <- paste0(txt, "filter_list=", .as_text_filter_list(fl), ")") - } - txt + cells <- cell_val_num(object) + fl <- filter_list(object) + nf <- nfilters(fl) + tp <- datatype(object) + dm <- if (is.na(cells)) "" else paste0(domain(object), if (grepl("INT", tp)) "L" else "", collape = "") + ex <- if (is.na(cells)) "" else paste0(tile(object), if (grepl("INT", tp)) "L" else "", collape = "") + txt <- paste0( + "tiledb_dim(name=\"", name(object), "\", ", + "domain=c(", if (is.na(cells)) { + "NULL,NULL" + } else { + paste0(dm, collapse = ",") + }, "), ", + "tile=", if (is.na(cells)) "NULL" else ex, ", ", + "type=\"", datatype(object), "\"", + if (nf == 0) ")" else ", " + ) + if (nf > 0) { + txt <- paste0(txt, "filter_list=", .as_text_filter_list(fl), ")") + } + txt } #' Prints a dimension object @@ -136,17 +156,20 @@ tiledb_dim <- function(name, domain, tile, type, #' @param object A dimension object #' @export setMethod("show", - signature(object = "tiledb_dim"), - definition = function(object) { + signature(object = "tiledb_dim"), + definition = function(object) { cat(.as_text_dimension(object), "\n") -}) + } +) #' Return the `tiledb_dim` name #' #' @param object `tiledb_dim` object #' @return string name, empty string if the dimension is anonymous #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' d1 <- tiledb_dim("d1", c(1L, 10L)) #' name(d1) #' @@ -154,25 +177,31 @@ setMethod("show", #' name(d2) #' #' @export -setMethod("name", signature(object = "tiledb_dim"), - function(object) { - return(libtiledb_dim_get_name(object@ptr)) - }) +setMethod( + "name", signature(object = "tiledb_dim"), + function(object) { + return(libtiledb_dim_get_name(object@ptr)) + } +) #' Return the `tiledb_dim` domain #' #' @param object `tiledb_dim` object #' @return a vector of (lb, ub) inclusive domain of the dimension #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' d1 <- tiledb_dim("d1", domain = c(5L, 10L)) #' domain(d1) #' #' @export -setMethod("domain", signature(object = "tiledb_dim"), - function(object) { - return(libtiledb_dim_get_domain(object@ptr)) - }) +setMethod( + "domain", signature(object = "tiledb_dim"), + function(object) { + return(libtiledb_dim_get_domain(object@ptr)) + } +) #' @rdname generics #' @export @@ -183,45 +212,57 @@ setGeneric("tile", function(object) standardGeneric("tile")) #' @param object `tiledb_dim` object #' @return a scalar tile extent #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' d1 <- tiledb_dim("d1", domain = c(5L, 10L), tile = 2L) #' tile(d1) #' #' @export -setMethod("tile", signature(object = "tiledb_dim"), - function(object) { - return(libtiledb_dim_get_tile_extent(object@ptr)) - }) +setMethod( + "tile", signature(object = "tiledb_dim"), + function(object) { + return(libtiledb_dim_get_tile_extent(object@ptr)) + } +) #' Return the `tiledb_dim` datatype #' #' @param object tiledb_dim object #' @return tiledb datatype string #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' d1 <- tiledb_dim("d1", domain = c(5L, 10L), tile = 2L, type = "INT32") #' datatype(d1) #' #' @export -setMethod("datatype", signature(object = "tiledb_dim"), - function(object) { - return(libtiledb_dim_get_datatype(object@ptr)) - }) +setMethod( + "datatype", signature(object = "tiledb_dim"), + function(object) { + return(libtiledb_dim_get_datatype(object@ptr)) + } +) #' Returns the number of dimensions for a tiledb domain object #' #' @param object tiledb_ndim object #' @return 1L #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' d1 <- tiledb_dim("d1", c(1L, 10L), 10L) #' tiledb_ndim(d1) #' #' @export -setMethod("tiledb_ndim", "tiledb_dim", - function(object) { - return(1L) - }) +setMethod( + "tiledb_ndim", "tiledb_dim", + function(object) { + return(1L) + } +) #' Returns TRUE if the tiledb_dim is anonymous #' @@ -230,7 +271,9 @@ setMethod("tiledb_ndim", "tiledb_dim", #' @param object `tiledb_dim` object #' @return TRUE or FALSE #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' d1 <- tiledb_dim("d1", c(1L, 10L), 10L) #' is.anonymous(d1) #' @@ -249,14 +292,16 @@ is.anonymous.tiledb_dim <- function(object) { #' @param x `tiledb_dim` object #' @return a vector of the tile_dim domain type, of the dim domain dimension (extent) #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' d1 <- tiledb_dim("d1", c(1L, 10L), 5L) #' dim(d1) #' #' @export dim.tiledb_dim <- function(x) { dtype <- datatype(x) - if (isTRUE(any(sapply(dtype, match, c("FLOAT32","FLOAT32"))))) { + if (isTRUE(any(sapply(dtype, match, c("FLOAT32", "FLOAT32"))))) { stop("dim() is only defined for integral domains") } dom <- domain(x) @@ -294,7 +339,7 @@ setReplaceMethod("filter_list", "tiledb_dim", function(x, value) { #' @rdname tiledb_dim_get_cell_val_num #' @export setMethod("cell_val_num", signature(object = "tiledb_dim"), function(object) { - libtiledb_dim_get_cell_val_num(object@ptr) + libtiledb_dim_get_cell_val_num(object@ptr) }) #' Return the number of scalar values per dimension cell @@ -303,5 +348,5 @@ setMethod("cell_val_num", signature(object = "tiledb_dim"), function(object) { #' @return integer number of cells #' @export tiledb_dim_get_cell_val_num <- function(object) { - libtiledb_dim_get_cell_val_num(object@ptr) + libtiledb_dim_get_cell_val_num(object@ptr) } diff --git a/R/Domain.R b/R/Domain.R index a9ad9a9bdb..1a3be12e5b 100644 --- a/R/Domain.R +++ b/R/Domain.R @@ -25,7 +25,8 @@ #' @slot ptr External pointer to the underlying implementation #' @exportClass tiledb_domain setClass("tiledb_domain", - slots = list(ptr = "externalptr")) + slots = list(ptr = "externalptr") +) tiledb_domain.from_ptr <- function(ptr) { stopifnot(`ptr must be a non-NULL externalptr to a tiledb_domain` = !missing(ptr) && is(ptr, "externalptr") && !is.null(ptr)) @@ -40,17 +41,21 @@ tiledb_domain.from_ptr <- function(ptr) { #' @param dims list() of tiledb_dim objects #' @return tiledb_domain #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} -#' dom <- tiledb_domain(dims = c(tiledb_dim("d1", c(1L, 100L), type = "INT32"), -#' tiledb_dim("d2", c(1L, 50L), type = "INT32"))) +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } +#' dom <- tiledb_domain(dims = c( +#' tiledb_dim("d1", c(1L, 100L), type = "INT32"), +#' tiledb_dim("d2", c(1L, 50L), type = "INT32") +#' )) #' @importFrom methods slot #' @importFrom methods new #' @export tiledb_domain tiledb_domain <- function(dims, ctx = tiledb_get_context()) { stopifnot(`Argument 'ctx' must be a tiledb_ctx object` = is(ctx, "tiledb_ctx")) is_dim <- function(obj) is(obj, "tiledb_dim") - if (is_dim(dims)) { # if a dim object given: - dims <- list(dims) # make it a vector so that lapply works below + if (is_dim(dims)) { # if a dim object given: + dims <- list(dims) # make it a vector so that lapply works below } if (missing(dims) || length(dims) == 0 || !all(vapply(dims, is_dim, logical(1)))) { stop("argument dims must be a list of one or more tileb_dim") @@ -67,30 +72,37 @@ tiledb_domain <- function(dims, ctx = tiledb_get_context()) { #' #' @param object A domain object #' @export -setMethod("raw_dump", - signature(object = "tiledb_domain"), - definition = function(object) libtiledb_domain_dump(object@ptr)) +setMethod( + "raw_dump", + signature(object = "tiledb_domain"), + definition = function(object) libtiledb_domain_dump(object@ptr) +) # internal function returning text use here and in other higher-level show() methods .as_text_domain <- function(object) { - txt <- "tiledb_domain(c(\n" - dims <- dimensions(object) - nd <- length(dims) - for (i in seq_len(nd)) { - txt <- paste0(txt, " ", .as_text_dimension(dims[[i]]), - if (i == nd) "\n ))" else ",\n") - } - txt + txt <- "tiledb_domain(c(\n" + dims <- dimensions(object) + nd <- length(dims) + for (i in seq_len(nd)) { + txt <- paste0( + txt, " ", .as_text_dimension(dims[[i]]), + if (i == nd) "\n ))" else ",\n" + ) + } + txt } #' Prints a domain object #' #' @param object A domain object #' @export -setMethod("show", "tiledb_domain", - definition = function(object) { +setMethod( + "show", + "tiledb_domain", + definition = function(object) { cat(.as_text_domain(object), "\n") -}) + } +) #' Returns a list of the tiledb_domain dimension objects #' @@ -98,58 +110,79 @@ setMethod("show", "tiledb_domain", #' @param object tiledb_domain #' @return a list of tiledb_dim #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} -#' dom <- tiledb_domain(dims = c(tiledb_dim("d1", c(1L, 100L), type = "INT32"), -#' tiledb_dim("d2", c(1L, 50L), type = "INT32"))) +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } +#' dom <- tiledb_domain(dims = c( +#' tiledb_dim("d1", c(1L, 100L), type = "INT32"), +#' tiledb_dim("d2", c(1L, 50L), type = "INT32") +#' )) #' dimensions(dom) #' #' lapply(dimensions(dom), name) #' #' @export -setMethod("dimensions", "tiledb_domain", - function(object) { - dim_ptrs <- libtiledb_domain_get_dimensions(object@ptr) - return(lapply(dim_ptrs, tiledb_dim.from_ptr)) - }) +setMethod( + "dimensions", + "tiledb_domain", + function(object) { + dim_ptrs <- libtiledb_domain_get_dimensions(object@ptr) + return(lapply(dim_ptrs, tiledb_dim.from_ptr)) + } +) #' Returns the tiledb_domain TileDB type string #' #' @param object tiledb_domain #' @return tiledb_domain type string #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' dom <- tiledb_domain(dims = c(tiledb_dim("d1", c(1L, 100L), type = "INT32"))) #' datatype(dom) #' dom <- tiledb_domain(dims = c(tiledb_dim("d1", c(0.5, 100.0), type = "FLOAT64"))) #' datatype(dom) #' #' @export -setMethod("datatype", "tiledb_domain", - function(object) { - ##return(libtiledb_domain_get_type(object@ptr)) - #generalize from domaintype <- libtiledb_domain_get_type(dom@ptr) to - domaintype <- sapply(libtiledb_domain_get_dimensions(object@ptr), - libtiledb_dim_get_datatype) - return(domaintype) -}) +setMethod( + "datatype", + "tiledb_domain", + function(object) { + ## return(libtiledb_domain_get_type(object@ptr)) + # generalize from domaintype <- libtiledb_domain_get_type(dom@ptr) to + domaintype <- sapply( + libtiledb_domain_get_dimensions(object@ptr), + libtiledb_dim_get_datatype + ) + return(domaintype) + } +) #' Returns the number of dimensions of the `tiledb_domain` #' #' @param object tiledb_domain #' @return integer number of dimensions #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' dom <- tiledb_domain(dims = c(tiledb_dim("d1", c(0.5, 100.0), type = "FLOAT64"))) #' tiledb_ndim(dom) -#' dom <- tiledb_domain(dims = c(tiledb_dim("d1", c(0.5, 100.0), type = "FLOAT64"), -#' tiledb_dim("d2", c(0.5, 100.0), type = "FLOAT64"))) +#' dom <- tiledb_domain(dims = c( +#' tiledb_dim("d1", c(0.5, 100.0), type = "FLOAT64"), +#' tiledb_dim("d2", c(0.5, 100.0), type = "FLOAT64") +#' )) #' tiledb_ndim(dom) #' #' @export -setMethod("tiledb_ndim", "tiledb_domain", - function(object) { - return(libtiledb_domain_get_ndim(object@ptr)) - }) +setMethod( + "tiledb_ndim", + "tiledb_domain", + function(object) { + return(libtiledb_domain_get_ndim(object@ptr)) + } +) #' @rdname generics #' @export @@ -160,19 +193,24 @@ setGeneric("is.integral", function(object) standardGeneric("is.integral")) #' @param object tiledb_domain #' @return TRUE if the domain is an integral domain, else FALSE #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' dom <- tiledb_domain(dims = c(tiledb_dim("d1", c(1L, 100L), type = "INT32"))) #' is.integral(dom) #' dom <- tiledb_domain(dims = c(tiledb_dim("d1", c(0.5, 100.0), type = "FLOAT64"))) #' is.integral(dom) #' #' @export -setMethod("is.integral", "tiledb_domain", - function(object) { - dtype <- datatype(object) - res <- isTRUE(any(sapply(dtype, match, c("FLOAT32","FLOAT32")))) - return(!res) - }) +setMethod( + "is.integral", + "tiledb_domain", + function(object) { + dtype <- datatype(object) + res <- isTRUE(any(sapply(dtype, match, c("FLOAT32", "FLOAT32")))) + return(!res) + } +) #' Retrieve the dimension (domain extent) of the domain #' @@ -181,15 +219,19 @@ setMethod("is.integral", "tiledb_domain", #' @param x tiledb_domain #' @return dimension vector #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} -#' dom <- tiledb_domain(dims = c(tiledb_dim("d1", c(1L, 100L), type = "INT32"), -#' tiledb_dim("d2", c(1L, 100L), type = "INT32"))) +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } +#' dom <- tiledb_domain(dims = c( +#' tiledb_dim("d1", c(1L, 100L), type = "INT32"), +#' tiledb_dim("d2", c(1L, 100L), type = "INT32") +#' )) #' dim(dom) #' #' @export dim.tiledb_domain <- function(x) { dtype <- datatype(x) - if (isTRUE(any(sapply(dtype, match, c("FLOAT32","FLOAT64"))))) { + if (isTRUE(any(sapply(dtype, match, c("FLOAT32", "FLOAT64"))))) { stop("dim() is only defined for integral domains") } return(vapply(dimensions(x), dim, integer(1L))) @@ -202,9 +244,11 @@ dim.tiledb_domain <- function(x) { #' @return TileDB Dimension object #' @export tiledb_domain_get_dimension_from_index <- function(domain, idx) { - stopifnot(`The 'domain' argument must be a tiledb_domain` = is(domain, "tiledb_domain"), - `The 'idx' argument must be numeric` = is.numeric(idx)) - return(new("tiledb_dim", ptr=libtiledb_domain_get_dimension_from_index(domain@ptr, idx))) + stopifnot( + `The 'domain' argument must be a tiledb_domain` = is(domain, "tiledb_domain"), + `The 'idx' argument must be numeric` = is.numeric(idx) + ) + return(new("tiledb_dim", ptr = libtiledb_domain_get_dimension_from_index(domain@ptr, idx))) } #' Returns a Dimension indicated by name for the given TileDB Domain @@ -214,9 +258,11 @@ tiledb_domain_get_dimension_from_index <- function(domain, idx) { #' @return TileDB Dimension object #' @export tiledb_domain_get_dimension_from_name <- function(domain, name) { - stopifnot(`The 'domain' argument must be a tiledb_domain` = is(domain, "tiledb_domain"), - `The 'name' argument must be character` = is.character(name)) - return(new("tiledb_dim", ptr=libtiledb_domain_get_dimension_from_name(domain@ptr, name))) + stopifnot( + `The 'domain' argument must be a tiledb_domain` = is(domain, "tiledb_domain"), + `The 'name' argument must be character` = is.character(name) + ) + return(new("tiledb_dim", ptr = libtiledb_domain_get_dimension_from_name(domain@ptr, name))) } #' Check a domain for a given dimension name @@ -226,7 +272,9 @@ tiledb_domain_get_dimension_from_name <- function(domain, name) { #' @return A boolean value indicating if the dimension exists in the domain #' @export tiledb_domain_has_dimension <- function(domain, name) { - stopifnot(`The 'domain' argument must be a tiledb_domain` = is(domain, "tiledb_domain"), - `The 'name' argument must be character` = is.character(name)) + stopifnot( + `The 'domain' argument must be a tiledb_domain` = is(domain, "tiledb_domain"), + `The 'name' argument must be character` = is.character(name) + ) libtiledb_domain_has_dimension(domain@ptr, name) } diff --git a/R/Error.R b/R/Error.R index 193bbbb750..32a7c9e22b 100644 --- a/R/Error.R +++ b/R/Error.R @@ -28,6 +28,6 @@ #' @return A character variable with the error message #' @export tiledb_error_message <- function(ctx = tiledb_get_context()) { - stopifnot(`The 'ctx' variable must be a TileDB Context object` = is(ctx, "tiledb_ctx")) - libtiledb_error_message(ctx@ptr) + stopifnot(`The 'ctx' variable must be a TileDB Context object` = is(ctx, "tiledb_ctx")) + libtiledb_error_message(ctx@ptr) } diff --git a/R/Filestore.R b/R/Filestore.R index 403718aad3..4f35350022 100644 --- a/R/Filestore.R +++ b/R/Filestore.R @@ -31,12 +31,14 @@ ##' @return An ArraySchema object corresponding to the supplied schema, or a default if missing ##' @export tiledb_filestore_schema_create <- function(uri = NULL, ctx = tiledb_get_context()) { - stopifnot("The 'ctx' argument must be a Context object" = is(ctx, "tiledb_ctx"), - "The 'uri' argument must be character" = is.null(uri) || is.character(uri), - "The 'uri' must providing an existing file" = is.null(uri) || file.exists(uri), - "This function needs TileDB 2.9.0 or later" = tiledb_version(TRUE) >= "2.9.0") - arrptr <- libtiledb_filestore_schema_create(ctx@ptr, if (is.null(uri)) "" else uri) - tiledb_array_schema.from_ptr(arrptr) + stopifnot( + "The 'ctx' argument must be a Context object" = is(ctx, "tiledb_ctx"), + "The 'uri' argument must be character" = is.null(uri) || is.character(uri), + "The 'uri' must providing an existing file" = is.null(uri) || file.exists(uri), + "This function needs TileDB 2.9.0 or later" = tiledb_version(TRUE) >= "2.9.0" + ) + arrptr <- libtiledb_filestore_schema_create(ctx@ptr, if (is.null(uri)) "" else uri) + tiledb_array_schema.from_ptr(arrptr) } ##' Import a file into a TileDB Filestore @@ -48,12 +50,14 @@ tiledb_filestore_schema_create <- function(uri = NULL, ctx = tiledb_get_context( ##' @return A boolean is returned to indicate successful completion ##' @export tiledb_filestore_uri_import <- function(filestore_uri, file_uri, ctx = tiledb_get_context()) { - stopifnot("The 'ctx' argument must be a Context object" = is(ctx, "tiledb_ctx"), - "The 'filestore_uri' argument must be character" = is.character(filestore_uri), - "The 'file_uri' argument must be character" = is.character(file_uri), - "The 'file_uri' must providing an existing file" = file.exists(file_uri), - "This function needs TileDB 2.9.0 or later" = tiledb_version(TRUE) >= "2.9.0") - libtiledb_filestore_uri_import(ctx@ptr, filestore_uri, file_uri) + stopifnot( + "The 'ctx' argument must be a Context object" = is(ctx, "tiledb_ctx"), + "The 'filestore_uri' argument must be character" = is.character(filestore_uri), + "The 'file_uri' argument must be character" = is.character(file_uri), + "The 'file_uri' must providing an existing file" = file.exists(file_uri), + "This function needs TileDB 2.9.0 or later" = tiledb_version(TRUE) >= "2.9.0" + ) + libtiledb_filestore_uri_import(ctx@ptr, filestore_uri, file_uri) } ##' Export a file from a TileDB Filestore @@ -65,11 +69,13 @@ tiledb_filestore_uri_import <- function(filestore_uri, file_uri, ctx = tiledb_ge ##' @return A boolean is returned to indicate successful completion ##' @export tiledb_filestore_uri_export <- function(file_uri, filestore_uri, ctx = tiledb_get_context()) { - stopifnot("The 'ctx' argument must be a Context object" = is(ctx, "tiledb_ctx"), - "The 'filestore_uri' argument must be character" = is.character(filestore_uri), - "The 'file_uri' argument must be character" = is.character(file_uri), - "This function needs TileDB 2.9.0 or later" = tiledb_version(TRUE) >= "2.9.0") - libtiledb_filestore_uri_export(ctx@ptr, file_uri, filestore_uri) + stopifnot( + "The 'ctx' argument must be a Context object" = is(ctx, "tiledb_ctx"), + "The 'filestore_uri' argument must be character" = is.character(filestore_uri), + "The 'file_uri' argument must be character" = is.character(file_uri), + "This function needs TileDB 2.9.0 or later" = tiledb_version(TRUE) >= "2.9.0" + ) + libtiledb_filestore_uri_export(ctx@ptr, file_uri, filestore_uri) } ##' Import size bytes from a string into a TileDB Filestore @@ -82,12 +88,14 @@ tiledb_filestore_uri_export <- function(file_uri, filestore_uri, ctx = tiledb_ge ##' @return A boolean is returned to indicate successful completion ##' @export tiledb_filestore_buffer_import <- function(filestore_uri, buf, bytes, ctx = tiledb_get_context()) { - if (missing(bytes)) bytes <- nchar(buf) - stopifnot("The 'ctx' argument must be a Context object" = is(ctx, "tiledb_ctx"), - "The 'filestore_uri' argument must be character" = is.character(filestore_uri), - "The 'buf' argument must be character" = is.character(buf), - "This function needs TileDB 2.9.0 or later" = tiledb_version(TRUE) >= "2.9.0") - libtiledb_filestore_buffer_import(ctx@ptr, filestore_uri, buf, bytes) + if (missing(bytes)) bytes <- nchar(buf) + stopifnot( + "The 'ctx' argument must be a Context object" = is(ctx, "tiledb_ctx"), + "The 'filestore_uri' argument must be character" = is.character(filestore_uri), + "The 'buf' argument must be character" = is.character(buf), + "This function needs TileDB 2.9.0 or later" = tiledb_version(TRUE) >= "2.9.0" + ) + libtiledb_filestore_buffer_import(ctx@ptr, filestore_uri, buf, bytes) } ##' Export from a TileDB Filestore to a character variable @@ -101,14 +109,16 @@ tiledb_filestore_buffer_import <- function(filestore_uri, buf, bytes, ctx = tile ##' bytes) is returned ##' @export tiledb_filestore_buffer_export <- function(filestore_uri, offset, bytes, ctx = tiledb_get_context()) { - if (missing(offset)) offset <- 0 - if (missing(bytes)) bytes <- tiledb_filestore_size(filestore_uri, ctx=ctx) - stopifnot("The 'ctx' argument must be a Context object" = is(ctx, "tiledb_ctx"), - "The 'filestore_uri' argument must be character" = is.character(filestore_uri), - "The 'offset' argument must be numeric" = is.numeric(offset), - "The 'bytes' argument must be numeric" = is.numeric(bytes), - "This function needs TileDB 2.9.0 or later" = tiledb_version(TRUE) >= "2.9.0") - libtiledb_filestore_buffer_export(ctx@ptr, filestore_uri, offset, bytes) + if (missing(offset)) offset <- 0 + if (missing(bytes)) bytes <- tiledb_filestore_size(filestore_uri, ctx = ctx) + stopifnot( + "The 'ctx' argument must be a Context object" = is(ctx, "tiledb_ctx"), + "The 'filestore_uri' argument must be character" = is.character(filestore_uri), + "The 'offset' argument must be numeric" = is.numeric(offset), + "The 'bytes' argument must be numeric" = is.numeric(bytes), + "This function needs TileDB 2.9.0 or later" = tiledb_version(TRUE) >= "2.9.0" + ) + libtiledb_filestore_buffer_export(ctx@ptr, filestore_uri, offset, bytes) } ##' Return (uncompressed) TileDB Filestore size @@ -119,5 +129,5 @@ tiledb_filestore_buffer_export <- function(filestore_uri, offset, bytes, ctx = t ##' @return A numeric with the size is returned ##' @export tiledb_filestore_size <- function(filestore_uri, ctx = tiledb_get_context()) { - libtiledb_filestore_size(ctx@ptr, filestore_uri) + libtiledb_filestore_size(ctx@ptr, filestore_uri) } diff --git a/R/Filter.R b/R/Filter.R index 19891daffe..b00cc9843c 100644 --- a/R/Filter.R +++ b/R/Filter.R @@ -25,7 +25,8 @@ #' @slot ptr External pointer to the underlying implementation #' @exportClass tiledb_filter setClass("tiledb_filter", - slots = list(ptr = "externalptr")) + slots = list(ptr = "externalptr") +) tiledb_filter.from_ptr <- function(ptr) { stopifnot("ptr must be a non-NULL externalptr to a tiledb_filter" = !missing(ptr) && is(ptr, "externalptr") && !is.null(ptr)) @@ -59,47 +60,57 @@ tiledb_filter.from_ptr <- function(ptr) { #' @param ctx tiledb_ctx object (optional) #' @return tiledb_filter object #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' tiledb_filter("ZSTD") #' #' @export tiledb_filter tiledb_filter <- function(name = "NONE", ctx = tiledb_get_context()) { - stopifnot("Argument 'ctx' must be a tiledb_ctx object" = is(ctx, "tiledb_ctx"), - "Argument 'filter' must be scalar string" = is.scalar(name, "character")) + stopifnot( + "Argument 'ctx' must be a tiledb_ctx object" = is(ctx, "tiledb_ctx"), + "Argument 'filter' must be scalar string" = is.scalar(name, "character") + ) ptr <- libtiledb_filter(ctx@ptr, name) return(new("tiledb_filter", ptr = ptr)) } # internal function returning text use here and in other higher-level show() methods .as_text_filter <- function(object) { - flt <- tiledb_filter_type(object) - opt <- .getFilterOption(object) - if (opt == "NA") { - txt <- paste0("tiledb_filter(\"", flt, "\")") - } else { - prt <- strsplit(opt, "=")[[1]] - txt <- paste0("tiledb_filter_set_option(tiledb_filter(\"", - flt, "\"),\"", prt[1], "\",", prt[2], ")") - } - txt + flt <- tiledb_filter_type(object) + opt <- .getFilterOption(object) + if (opt == "NA") { + txt <- paste0("tiledb_filter(\"", flt, "\")") + } else { + prt <- strsplit(opt, "=")[[1]] + txt <- paste0( + "tiledb_filter_set_option(tiledb_filter(\"", + flt, "\"),\"", prt[1], "\",", prt[2], ")" + ) + } + txt } #' Prints a filter object #' #' @param object A filter object #' @export -setMethod("show", - signature(object = "tiledb_filter"), - definition = function(object) { +setMethod( + "show", + signature(object = "tiledb_filter"), + definition = function(object) { cat(.as_text_filter(object), "\n") -}) + } +) #' Returns the type of the filter used #' #' @param object tiledb_filter #' @return TileDB filter type string #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' c <- tiledb_filter("ZSTD") #' tiledb_filter_type(c) #' @@ -116,15 +127,19 @@ tiledb_filter_type <- function(object) { #' @param value int #' @return The modified filter object is returned. #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' c <- tiledb_filter("ZSTD") -#' tiledb_filter_set_option(c,"COMPRESSION_LEVEL", 5) +#' tiledb_filter_set_option(c, "COMPRESSION_LEVEL", 5) #' tiledb_filter_get_option(c, "COMPRESSION_LEVEL") #' @export tiledb_filter_set_option <- function(object, option, value) { - stopifnot("The 'object' argument must be a tiledb_filter" = is(object, "tiledb_filter"), - "The 'option' argument must be character" = is.character(option), - "The 'value' argument must be numeric or character or logical" = is.numeric(value) || is.character(value) || is.logical(value)) + stopifnot( + "The 'object' argument must be a tiledb_filter" = is(object, "tiledb_filter"), + "The 'option' argument must be character" = is.character(option), + "The 'value' argument must be numeric or character or logical" = is.numeric(value) || is.character(value) || is.logical(value) + ) object@ptr <- libtiledb_filter_set_option(object@ptr, option, value) return(object) @@ -136,14 +151,18 @@ tiledb_filter_set_option <- function(object, option, value) { #' @param option string #' @return Integer value #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' c <- tiledb_filter("ZSTD") -#' tiledb_filter_set_option(c,"COMPRESSION_LEVEL", 5) +#' tiledb_filter_set_option(c, "COMPRESSION_LEVEL", 5) #' tiledb_filter_get_option(c, "COMPRESSION_LEVEL") #' #' @export tiledb_filter_get_option <- function(object, option) { - stopifnot("The 'object' argument must be a tiledb_filter" = is(object, "tiledb_filter"), - "The 'option' argument must be character" = is.character(option)) + stopifnot( + "The 'object' argument must be a tiledb_filter" = is(object, "tiledb_filter"), + "The 'option' argument must be character" = is.character(option) + ) return(libtiledb_filter_get_option(object@ptr, option)) } diff --git a/R/FilterList.R b/R/FilterList.R index 879cc21804..0866ed5d7c 100644 --- a/R/FilterList.R +++ b/R/FilterList.R @@ -25,7 +25,8 @@ #' @slot ptr An external pointer to the underlying implementation #' @exportClass tiledb_filter_list setClass("tiledb_filter_list", - slots = list(ptr = "externalptr")) + slots = list(ptr = "externalptr") +) tiledb_filter_list.from_ptr <- function(ptr) { stopifnot(`ptr must be a non-NULL externalptr to a tiledb_filter_list` = !missing(ptr) && is(ptr, "externalptr") && !is.null(ptr)) @@ -39,7 +40,9 @@ tiledb_filter_list.from_ptr <- function(ptr) { #' @param ctx tiledb_ctx object (optional) #' @return tiledb_filter_list object #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' flt <- tiledb_filter("ZSTD") #' tiledb_filter_set_option(flt, "COMPRESSION_LEVEL", 5) #' filter_list <- tiledb_filter_list(c(flt)) @@ -49,10 +52,10 @@ tiledb_filter_list.from_ptr <- function(ptr) { tiledb_filter_list <- function(filters = c(), ctx = tiledb_get_context()) { stopifnot(`Argument 'ctx' must be a tiledb_ctx object` = is(ctx, "tiledb_ctx")) is_filter <- function(obj) is(obj, "tiledb_filter") - if (is_filter(filters)) { # if a filters object given: - filters <- list(filters) # make it a list so that lapply works below + if (is_filter(filters)) { # if a filters object given: + filters <- list(filters) # make it a list so that lapply works below } - filter_ptrs = c() + filter_ptrs <- c() if (length(filters) > 0) { if (!all(vapply(filters, is_filter, logical(1)))) { stop("filters argument must be a list of one or tiledb_filter objects") @@ -65,52 +68,64 @@ tiledb_filter_list <- function(filters = c(), ctx = tiledb_get_context()) { # internal function returning text use here and in other higher-level show() methods .as_text_filter_list <- function(object) { - n <- nfilters(object) - if (n == 0) return("") - txt <- "tiledb_filter_list(c(" - for (i in seq_len(n)) { - ## The i-1 is necessary as these are 0-up indexed (unusual for R, a leftover from older code) - txt <- paste0(txt, .as_text_filter(object[i-1]), if (i == n) ")" else ", ") - } - txt <- paste0(txt, ")") + n <- nfilters(object) + if (n == 0) { + return("") + } + txt <- "tiledb_filter_list(c(" + for (i in seq_len(n)) { + ## The i-1 is necessary as these are 0-up indexed (unusual for R, a leftover from older code) + txt <- paste0(txt, .as_text_filter(object[i - 1]), if (i == n) ")" else ", ") + } + txt <- paste0(txt, ")") } #' Prints a filter_list object #' #' @param object A filter_list object #' @export -setMethod("show", - signature(object = "tiledb_filter_list"), - definition = function(object) { +setMethod( + "show", + signature(object = "tiledb_filter_list"), + definition = function(object) { cat(.as_text_filter_list(object), "\n") -}) + } +) #' @rdname tiledb_filter_list_set_max_chunk_size #' @export -setGeneric("set_max_chunk_size", function(object, value) standardGeneric("set_max_chunk_size")) +setGeneric( + "set_max_chunk_size", + function(object, value) standardGeneric("set_max_chunk_size")) #' @rdname tiledb_filter_list_set_max_chunk_size #' @export -setMethod("set_max_chunk_size", - signature(object = "tiledb_filter_list", value = "numeric"), - function(object, value) { - libtiledb_filter_list_set_max_chunk_size(object@ptr, value) -}) +setMethod( + "set_max_chunk_size", + signature(object = "tiledb_filter_list", value = "numeric"), + function(object, value) { + libtiledb_filter_list_set_max_chunk_size(object@ptr, value) + } +) #' Set the filter_list's max_chunk_size #' #' @param object tiledb_filter_list #' @param value A numeric value #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' flt <- tiledb_filter("ZSTD") #' tiledb_filter_set_option(flt, "COMPRESSION_LEVEL", 5) #' filter_list <- tiledb_filter_list(c(flt)) #' set_max_chunk_size(filter_list, 10) #' @export tiledb_filter_list_set_max_chunk_size <- function(object, value) { - stopifnot(`The 'object' argument must be a tiledb_filter_list` = is(object, "tiledb_filter_list"), - `The 'value' argument must be numeric` = is.numeric(value)) + stopifnot( + `The 'object' argument must be a tiledb_filter_list` = is(object, "tiledb_filter_list"), + `The 'value' argument must be numeric` = is.numeric(value) + ) libtiledb_filter_list_set_max_chunk_size(object@ptr, value) } @@ -120,7 +135,10 @@ setGeneric("max_chunk_size", function(object) standardGeneric("max_chunk_size")) #' @rdname tiledb_filter_list_get_max_chunk_size #' @export -setMethod("max_chunk_size", signature(object = "tiledb_filter_list"), function(object) { +setMethod( + "max_chunk_size", + signature(object = "tiledb_filter_list"), + function(object) { libtiledb_filter_list_get_max_chunk_size(object@ptr) }) @@ -129,7 +147,9 @@ setMethod("max_chunk_size", signature(object = "tiledb_filter_list"), function(o #' @param object tiledb_filter_list #' @return integer max_chunk_size #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' flt <- tiledb_filter("ZSTD") #' tiledb_filter_set_option(flt, "COMPRESSION_LEVEL", 5) #' filter_list <- tiledb_filter_list(c(flt)) @@ -151,21 +171,25 @@ setGeneric("nfilters", function(object) standardGeneric("nfilters")) #' @param object tiledb_filter_list #' @return integer number of filters #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' flt <- tiledb_filter("ZSTD") #' tiledb_filter_set_option(flt, "COMPRESSION_LEVEL", 5) #' filter_list <- tiledb_filter_list(c(flt)) #' nfilters(filter_list) #' #' @export -setMethod("nfilters", signature(object = "tiledb_filter_list"), - function(object) { - libtiledb_filter_list_get_nfilters(object@ptr) - }) +setMethod( + "nfilters", + signature(object = "tiledb_filter_list"), + function(object) { + libtiledb_filter_list_get_nfilters(object@ptr) + } +) #' Returns the filter at given index - - +#' #' @param x `tiledb_config` object #' @param i parameter key string #' @param j parameter key string, currently unused. @@ -173,7 +197,9 @@ setMethod("nfilters", signature(object = "tiledb_filter_list"), #' @param drop Optional logical switch to drop dimensions, default false. #' @return object tiledb_filter #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' flt <- tiledb_filter("ZSTD") #' tiledb_filter_set_option(flt, "COMPRESSION_LEVEL", 5) #' filter_list <- tiledb_filter_list(c(flt)) @@ -184,7 +210,9 @@ setMethod("nfilters", signature(object = "tiledb_filter_list"), #' @aliases [,tiledb_filter_list-method #' @aliases [,tiledb_filter_list,ANY,tiledb_filter_list-method #' @aliases [,tiledb_filter_list,ANY,ANY,tiledb_filter_list-method -setMethod("[", "tiledb_filter_list", - function(x, i, j, ..., drop = FALSE) { - tiledb_filter.from_ptr(libtiledb_filter_list_get_filter_from_index(x@ptr, i)) - }) +setMethod( + "[", "tiledb_filter_list", + function(x, i, j, ..., drop = FALSE) { + tiledb_filter.from_ptr(libtiledb_filter_list_get_filter_from_index(x@ptr, i)) + } +) diff --git a/R/FragmentInfo.R b/R/FragmentInfo.R index 7d4899e4a5..451f5b5986 100644 --- a/R/FragmentInfo.R +++ b/R/FragmentInfo.R @@ -25,11 +25,12 @@ #' @slot ptr An external pointer to the underlying implementation #' @exportClass tiledb_fragment_info setClass("tiledb_fragment_info", - slots = list(ptr = "externalptr")) + slots = list(ptr = "externalptr") +) tiledb_fragment_info.from_ptr <- function(ptr) { - stopifnot(`ptr must be a non-NULL externalptr to a tiledb_fragment_info` = !missing(ptr) && is(ptr, "externalptr") && !is.null(ptr)) - return(new("tiledb_fragment_info", ptr = ptr)) + stopifnot(`ptr must be a non-NULL externalptr to a tiledb_fragment_info` = !missing(ptr) && is(ptr, "externalptr") && !is.null(ptr)) + return(new("tiledb_fragment_info", ptr = ptr)) } #' Constructs a `tiledb_fragment_info` object @@ -40,10 +41,12 @@ tiledb_fragment_info.from_ptr <- function(ptr) { #' @return tiledb_fragment_info object #' @export tiledb_fragment_info tiledb_fragment_info <- function(uri, ctx = tiledb_get_context()) { - stopifnot(`Argument 'ctx' must be a tiledb_ctx object` = is(ctx, "tiledb_ctx"), - `Argument 'uri' must be a string scalar` = is.scalar(uri, "character")) - ptr <- libtiledb_fragment_info(ctx@ptr, uri) - return(new("tiledb_fragment_info", ptr = ptr)) + stopifnot( + `Argument 'ctx' must be a tiledb_ctx object` = is(ctx, "tiledb_ctx"), + `Argument 'uri' must be a string scalar` = is.scalar(uri, "character") + ) + ptr <- libtiledb_fragment_info(ctx@ptr, uri) + return(new("tiledb_fragment_info", ptr = ptr)) } #' Return a fragment info URI given its index @@ -53,9 +56,11 @@ tiledb_fragment_info <- function(uri, ctx = tiledb_get_context()) { #' @return A character variable with URI #' @export tiledb_fragment_info_uri <- function(object, fid) { - stopifnot(`Argument object must be a tiledb_fragment_info` = is(object, "tiledb_fragment_info"), - `Argument fid must be a numeric` = is.numeric(fid)) - libtiledb_fragment_info_uri(object@ptr, fid) + stopifnot( + `Argument object must be a tiledb_fragment_info` = is(object, "tiledb_fragment_info"), + `Argument fid must be a numeric` = is.numeric(fid) + ) + libtiledb_fragment_info_uri(object@ptr, fid) } #' Return a fragment info non-empty domain from index @@ -70,20 +75,22 @@ tiledb_fragment_info_uri <- function(object, fid) { #' @return A TileDB Domain object #' @export tiledb_fragment_info_get_non_empty_domain_index <- function(object, fid, did, typestr) { - stopifnot(`Argument object must be a tiledb_fragment_info` = is(object, "tiledb_fragment_info"), - `Argument fid must be a numeric` = is.numeric(fid), - `Argument did must be a numeric` = is.numeric(did)) - if (missing(typestr)) { - uri <- dirname(libtiledb_fragment_info_uri(object@ptr, fid)) - if (grepl("__fragments$", uri)) uri <- dirname(uri) - typestr <- datatype( dimensions(domain(schema(uri)))[[did+1]] ) - } - spdl::debug("[tiledb_fragment_info_get_non_empty_domain_index] fid {} did {} typestr {}", fid, did, typestr) - if (typestr == "ASCII") { - libtiledb_fragment_info_get_non_empty_domain_var_index(object@ptr, fid, did) - } else { - libtiledb_fragment_info_get_non_empty_domain_index(object@ptr, fid, did, typestr) - } + stopifnot( + `Argument object must be a tiledb_fragment_info` = is(object, "tiledb_fragment_info"), + `Argument fid must be a numeric` = is.numeric(fid), + `Argument did must be a numeric` = is.numeric(did) + ) + if (missing(typestr)) { + uri <- dirname(libtiledb_fragment_info_uri(object@ptr, fid)) + if (grepl("__fragments$", uri)) uri <- dirname(uri) + typestr <- datatype(dimensions(domain(schema(uri)))[[did + 1]]) + } + spdl::debug("[tiledb_fragment_info_get_non_empty_domain_index] fid {} did {} typestr {}", fid, did, typestr) + if (typestr == "ASCII") { + libtiledb_fragment_info_get_non_empty_domain_var_index(object@ptr, fid, did) + } else { + libtiledb_fragment_info_get_non_empty_domain_index(object@ptr, fid, did, typestr) + } } #' Return a fragment info non-empty domain from name @@ -98,22 +105,24 @@ tiledb_fragment_info_get_non_empty_domain_index <- function(object, fid, did, ty #' @return A TileDB Domain object #' @export tiledb_fragment_info_get_non_empty_domain_name <- function(object, fid, dim_name, typestr) { - stopifnot(`Argument object must be a tiledb_fragment_info` = is(object, "tiledb_fragment_info"), - `Argument fid must be a numeric` = is.numeric(fid), - `Argument dim_name must be a scalar character` = is.scalar(dim_name, "character")) - if (missing(typestr)) { - uri <- dirname(libtiledb_fragment_info_uri(object@ptr, fid)) - if (grepl("__fragments$", uri)) uri <- dirname(uri) - names <- sapply(dimensions(domain(schema(uri))), name) - ind <- which(names == dim_name) - typestr <- datatype( dimensions(domain(schema(uri)))[[ind]] ) - } - spdl::debug("[tiledb_fragment_info_get_non_empty_domain_name] fid {} dimname {} typestr {}", fid, dim_name, typestr) - if (typestr == "ASCII") { - libtiledb_fragment_info_get_non_empty_domain_var_name(object@ptr, fid, dim_name) - } else { - libtiledb_fragment_info_get_non_empty_domain_name(object@ptr, fid, dim_name, typestr) - } + stopifnot( + `Argument object must be a tiledb_fragment_info` = is(object, "tiledb_fragment_info"), + `Argument fid must be a numeric` = is.numeric(fid), + `Argument dim_name must be a scalar character` = is.scalar(dim_name, "character") + ) + if (missing(typestr)) { + uri <- dirname(libtiledb_fragment_info_uri(object@ptr, fid)) + if (grepl("__fragments$", uri)) uri <- dirname(uri) + names <- sapply(dimensions(domain(schema(uri))), name) + ind <- which(names == dim_name) + typestr <- datatype(dimensions(domain(schema(uri)))[[ind]]) + } + spdl::debug("[tiledb_fragment_info_get_non_empty_domain_name] fid {} dimname {} typestr {}", fid, dim_name, typestr) + if (typestr == "ASCII") { + libtiledb_fragment_info_get_non_empty_domain_var_name(object@ptr, fid, dim_name) + } else { + libtiledb_fragment_info_get_non_empty_domain_name(object@ptr, fid, dim_name, typestr) + } } #' Return a fragment info non-empty domain variable from index @@ -124,10 +133,12 @@ tiledb_fragment_info_get_non_empty_domain_name <- function(object, fid, dim_name #' @return A character vector with two elements #' @export tiledb_fragment_info_get_non_empty_domain_var_index <- function(object, fid, did) { - stopifnot(`Argument object must be a tiledb_fragment_info` = is(object, "tiledb_fragment_info"), - `Argument fid must be a numeric` = is.numeric(fid), - `Argument did must be a numeric` = is.numeric(did)) - libtiledb_fragment_info_get_non_empty_domain_var_index(object@ptr, fid, did) + stopifnot( + `Argument object must be a tiledb_fragment_info` = is(object, "tiledb_fragment_info"), + `Argument fid must be a numeric` = is.numeric(fid), + `Argument did must be a numeric` = is.numeric(did) + ) + libtiledb_fragment_info_get_non_empty_domain_var_index(object@ptr, fid, did) } #' Return a fragment info non-empty domain variable from name @@ -138,10 +149,12 @@ tiledb_fragment_info_get_non_empty_domain_var_index <- function(object, fid, did #' @return A character vector with two elements #' @export tiledb_fragment_info_get_non_empty_domain_var_name <- function(object, fid, dim_name) { - stopifnot(`Argument object must be a tiledb_fragment_info` = is(object, "tiledb_fragment_info"), - `Argument fid must be a numeric` = is.numeric(fid), - `Argument dim_name must be a scalar character` = is.scalar(dim_name, "character")) - libtiledb_fragment_info_get_non_empty_domain_var_name(object@ptr, fid, dim_name) + stopifnot( + `Argument object must be a tiledb_fragment_info` = is(object, "tiledb_fragment_info"), + `Argument fid must be a numeric` = is.numeric(fid), + `Argument dim_name must be a scalar character` = is.scalar(dim_name, "character") + ) + libtiledb_fragment_info_get_non_empty_domain_var_name(object@ptr, fid, dim_name) } #' Return a fragment info number of fragments @@ -150,8 +163,8 @@ tiledb_fragment_info_get_non_empty_domain_var_name <- function(object, fid, dim_ #' @return A numeric variable with the number of fragments #' @export tiledb_fragment_info_get_num <- function(object) { - stopifnot(`Argument object must be a tiledb_fragment_info` = is(object, "tiledb_fragment_info")) - libtiledb_fragment_info_num(object@ptr) + stopifnot(`Argument object must be a tiledb_fragment_info` = is(object, "tiledb_fragment_info")) + libtiledb_fragment_info_num(object@ptr) } #' Return a fragment info fragment size for a given fragment index @@ -161,9 +174,11 @@ tiledb_fragment_info_get_num <- function(object) { #' @return A numeric variable with the number of fragments #' @export tiledb_fragment_info_get_size <- function(object, fid) { - stopifnot(`Argument object must be a tiledb_fragment_info` = is(object, "tiledb_fragment_info"), - `Argument fid must be a numeric` = is.numeric(fid)) - libtiledb_fragment_info_size(object@ptr, fid) + stopifnot( + `Argument object must be a tiledb_fragment_info` = is(object, "tiledb_fragment_info"), + `Argument fid must be a numeric` = is.numeric(fid) + ) + libtiledb_fragment_info_size(object@ptr, fid) } #' Return if a fragment info index is dense @@ -173,9 +188,11 @@ tiledb_fragment_info_get_size <- function(object, fid) { #' @return A logical value indicating if the fragment is dense #' @export tiledb_fragment_info_dense <- function(object, fid) { - stopifnot(`Argument object must be a tiledb_fragment_info` = is(object, "tiledb_fragment_info"), - `Argument fid must be a numeric` = is.numeric(fid)) - libtiledb_fragment_info_dense(object@ptr, fid) + stopifnot( + `Argument object must be a tiledb_fragment_info` = is(object, "tiledb_fragment_info"), + `Argument fid must be a numeric` = is.numeric(fid) + ) + libtiledb_fragment_info_dense(object@ptr, fid) } #' Return if a fragment info index is sparse @@ -185,9 +202,11 @@ tiledb_fragment_info_dense <- function(object, fid) { #' @return A logical value indicating if the fragment is sparse #' @export tiledb_fragment_info_sparse <- function(object, fid) { - stopifnot(`Argument object must be a tiledb_fragment_info` = is(object, "tiledb_fragment_info"), - `Argument fid must be a numeric` = is.numeric(fid)) - libtiledb_fragment_info_sparse(object@ptr, fid) + stopifnot( + `Argument object must be a tiledb_fragment_info` = is(object, "tiledb_fragment_info"), + `Argument fid must be a numeric` = is.numeric(fid) + ) + libtiledb_fragment_info_sparse(object@ptr, fid) } #' Return a fragment info timestamp range for a given fragment index @@ -197,7 +216,7 @@ tiledb_fragment_info_sparse <- function(object, fid) { #' @return A Datetime vector with two elements for the range #' @export tiledb_fragment_info_get_timestamp_range <- function(object, fid) { - libtiledb_fragment_info_timestamp_range(object@ptr, fid) + libtiledb_fragment_info_timestamp_range(object@ptr, fid) } #' Return a fragment info number of cells for a given fragment index @@ -207,9 +226,11 @@ tiledb_fragment_info_get_timestamp_range <- function(object, fid) { #' @return A numeric value with the number of cells #' @export tiledb_fragment_info_get_cell_num <- function(object, fid) { - stopifnot(`Argument object must be a tiledb_fragment_info` = is(object, "tiledb_fragment_info"), - `Argument fid must be a numeric` = is.numeric(fid)) - libtiledb_fragment_info_cell_num(object@ptr, fid) + stopifnot( + `Argument object must be a tiledb_fragment_info` = is(object, "tiledb_fragment_info"), + `Argument fid must be a numeric` = is.numeric(fid) + ) + libtiledb_fragment_info_cell_num(object@ptr, fid) } #' Return a fragment info version for a given fragment index @@ -219,7 +240,7 @@ tiledb_fragment_info_get_cell_num <- function(object, fid) { #' @return A integer value value with the version #' @export tiledb_fragment_info_get_version <- function(object, fid) { - libtiledb_fragment_info_version(object@ptr, fid) + libtiledb_fragment_info_version(object@ptr, fid) } #' Return if a fragment info index has consolidated metadata @@ -229,9 +250,11 @@ tiledb_fragment_info_get_version <- function(object, fid) { #' @return A logical value indicating consolidated metadata #' @export tiledb_fragment_info_has_consolidated_metadata <- function(object, fid) { - stopifnot(`Argument object must be a tiledb_fragment_info` = is(object, "tiledb_fragment_info"), - `Argument fid must be a numeric` = is.numeric(fid)) - libtiledb_fragment_info_has_consolidated_metadata(object@ptr, fid) + stopifnot( + `Argument object must be a tiledb_fragment_info` = is(object, "tiledb_fragment_info"), + `Argument fid must be a numeric` = is.numeric(fid) + ) + libtiledb_fragment_info_has_consolidated_metadata(object@ptr, fid) } #' Return fragment info number of unconsolidated metadata @@ -240,8 +263,8 @@ tiledb_fragment_info_has_consolidated_metadata <- function(object, fid) { #' @return A numeric value with the number of unconsolidated metadata #' @export tiledb_fragment_info_get_unconsolidated_metadata_num <- function(object) { - stopifnot(`Argument object must be a tiledb_fragment_info` = is(object, "tiledb_fragment_info")) - libtiledb_fragment_info_unconsolidated_metadata_num(object@ptr) + stopifnot(`Argument object must be a tiledb_fragment_info` = is(object, "tiledb_fragment_info")) + libtiledb_fragment_info_unconsolidated_metadata_num(object@ptr) } #' Return the number of fragment info elements to be vacuumed @@ -250,8 +273,8 @@ tiledb_fragment_info_get_unconsolidated_metadata_num <- function(object) { #' @return A numeric value with the number of to be vacuumed fragments #' @export tiledb_fragment_info_get_to_vacuum_num <- function(object) { - stopifnot(`Argument object must be a tiledb_fragment_info` = is(object, "tiledb_fragment_info")) - libtiledb_fragment_info_to_vacuum_num(object@ptr) + stopifnot(`Argument object must be a tiledb_fragment_info` = is(object, "tiledb_fragment_info")) + libtiledb_fragment_info_to_vacuum_num(object@ptr) } #' Return fragment info URI of the to be vacuumed index @@ -261,9 +284,11 @@ tiledb_fragment_info_get_to_vacuum_num <- function(object) { #' @return A character variable with the URI of the be vacuumed index #' @export tiledb_fragment_info_get_to_vacuum_uri <- function(object, fid) { - stopifnot(`Argument object must be a tiledb_fragment_info` = is(object, "tiledb_fragment_info"), - `Argument fid must be a numeric` = is.numeric(fid)) - libtiledb_fragment_info_to_vacuum_uri(object@ptr, fid) + stopifnot( + `Argument object must be a tiledb_fragment_info` = is(object, "tiledb_fragment_info"), + `Argument fid must be a numeric` = is.numeric(fid) + ) + libtiledb_fragment_info_to_vacuum_uri(object@ptr, fid) } #' Dump the fragment info to console @@ -272,6 +297,6 @@ tiledb_fragment_info_get_to_vacuum_uri <- function(object, fid) { #' @return Nothing is returned, as a side effect the fragment info is displayed #' @export tiledb_fragment_info_dump <- function(object) { - stopifnot(`Argument object must be a tiledb_fragment_info` = is(object, "tiledb_fragment_info")) - libtiledb_fragment_info_dump(object@ptr) + stopifnot(`Argument object must be a tiledb_fragment_info` = is(object, "tiledb_fragment_info")) + libtiledb_fragment_info_dump(object@ptr) } diff --git a/R/Group.R b/R/Group.R index 3ffed3eee4..53276d7b49 100644 --- a/R/Group.R +++ b/R/Group.R @@ -25,91 +25,113 @@ #' @slot ptr An external pointer to the underlying implementation #' @exportClass tiledb_group setClass("tiledb_group", - slots = list(ptr = "externalptr")) + slots = list(ptr = "externalptr") +) .tiledb28 <- function() tiledb_version(TRUE) >= "2.8.0" #' Creates a 'tiledb_group' object #' #' @param uri Character variable with the URI of the new group object -#' @param type Character variable with the query type value: one of \dQuote{READ} -#' or \dQuote{WRITE} +#' @param type Character variable with the query type value: one of +#' \dQuote{READ} or \dQuote{WRITE} #' @param ctx (optional) A TileDB Context object; if not supplied the default #' context object is retrieved #' @param cfg (optional) A TileConfig object #' @return A 'group' object #' @export -tiledb_group <- function(uri, type = c("READ", "WRITE"), - ctx = tiledb_get_context(), cfg = NULL) { - stopifnot("The 'ctx' argument must be a Context object" = is(ctx, "tiledb_ctx"), - "The 'uri' argument must be character" = is.character(uri), - "This function needs TileDB 2.8.*" = .tiledb28(), - "The 'config argument must be a Config object" = - is.null(cfg) || is(cfg, "tiledb_config")) - type <- match.arg(type) - if (is.null(cfg)) { - ptr <- libtiledb_group(ctx@ptr, uri, type) - } else { - ptr <- libtiledb_group_with_config(ctx@ptr, uri, type, cfg@ptr) - } - group <- new("tiledb_group", ptr = ptr) - invisible(group) +tiledb_group <- function( + uri, + type = c("READ", "WRITE"), + ctx = tiledb_get_context(), + cfg = NULL +) { + stopifnot( + "The 'ctx' argument must be a Context object" = is(ctx, "tiledb_ctx"), + "The 'uri' argument must be character" = is.character(uri), + "This function needs TileDB 2.8.*" = .tiledb28(), + "The 'config argument must be a Config object" = + is.null(cfg) || is(cfg, "tiledb_config") + ) + type <- match.arg(type) + if (is.null(cfg)) { + ptr <- libtiledb_group(ctx@ptr, uri, type) + } else { + ptr <- libtiledb_group_with_config(ctx@ptr, uri, type, cfg@ptr) + } + group <- new("tiledb_group", ptr = ptr) + invisible(group) } ##' Open a TileDB Group ##' -##' @param grp A TileDB Group object as for example returned by \code{tiledb_group()} -##' @param type A character value that must be either \sQuote{READ}, \sQuote{WRITE} -##' or \sQuote{MODIFY_EXCLUSIVE} +##' @param grp A TileDB Group object as for example returned by +##' \code{tiledb_group()} +##' @param type A character value that must be either \sQuote{READ}, +##' \sQuote{WRITE} or \sQuote{MODIFY_EXCLUSIVE} ##' @return The TileDB Group object but opened for reading or writing ##' @export -tiledb_group_open <- function(grp, type=c("READ","WRITE","MODIFY_EXCLUSIVE")) { - stopifnot("The 'grp' argument must be a tiledb_group object" = is(grp, "tiledb_group"), - "This function needs TileDB 2.8.*" = .tiledb28(), - "Using 'MODIFY_EXCLUSIVE' needs TileDB 2.12.* or later" = - type != "MODIFY_EXCLUSIVE" || tiledb_version(TRUE) >= "2.12.0") - type <- match.arg(type) - grp@ptr <- libtiledb_group_open(grp@ptr, type) - grp +tiledb_group_open <- function( + grp, + type = c("READ", "WRITE", "MODIFY_EXCLUSIVE") +) { + stopifnot( + "The 'grp' argument must be a tiledb_group object" = is(grp, "tiledb_group"), + "This function needs TileDB 2.8.*" = .tiledb28(), + "Using 'MODIFY_EXCLUSIVE' needs TileDB 2.12.* or later" = + type != "MODIFY_EXCLUSIVE" || tiledb_version(TRUE) >= "2.12.0" + ) + type <- match.arg(type) + grp@ptr <- libtiledb_group_open(grp@ptr, type) + grp } ##' Set a TileDB Config for a TileDB Group ##' -##' @param grp A TileDB Group object as for example returned by \code{tiledb_group()} +##' @param grp A TileDB Group object as for example returned by +##' \code{tiledb_group()} ##' @param cfg A TileDB Config object ##' @return The TileDB Group object with added Config ##' @export tiledb_group_set_config <- function(grp, cfg) { - stopifnot("The 'grp' argument must be a tiledb_group object" = is(grp, "tiledb_group"), - "The 'cfg' argument must be a tiledb_config object" = is(cfg, "tiledb_config"), - "This function needs TileDB 2.8.*" = .tiledb28()) - grp@ptr <- libtiledb_group_set_config(grp@ptr, cfg@ptr) - grp + stopifnot( + "The 'grp' argument must be a tiledb_group object" = is(grp, "tiledb_group"), + "The 'cfg' argument must be a tiledb_config object" = is(cfg, "tiledb_config"), + "This function needs TileDB 2.8.*" = .tiledb28() + ) + grp@ptr <- libtiledb_group_set_config(grp@ptr, cfg@ptr) + grp } ##' Get a TileDB Config from a TileDB Group ##' -##' @param grp A TileDB Group object as for example returned by \code{tiledb_group()} +##' @param grp A TileDB Group object as for example returned by +##' \code{tiledb_group()} ##' @return The TileDB Config object of the TileDB Group object ##' @export tiledb_group_get_config <- function(grp) { - stopifnot("The 'grp' argument must be a tiledb_group object" = is(grp, "tiledb_group"), - "This function needs TileDB 2.8.*" = .tiledb28()) - ptr <- libtiledb_group_get_config(grp@ptr) - cfg <- new("tiledb_config", ptr = ptr) - cfg + stopifnot( + "The 'grp' argument must be a tiledb_group object" = is(grp, "tiledb_group"), + "This function needs TileDB 2.8.*" = .tiledb28() + ) + ptr <- libtiledb_group_get_config(grp@ptr) + cfg <- new("tiledb_config", ptr = ptr) + cfg } ##' Close a TileDB Group ##' -##' @param grp A TileDB Group object as for example returned by \code{tiledb_group()} +##' @param grp A TileDB Group object as for example returned by +##' \code{tiledb_group()} ##' @return The TileDB Group object but closed for reading or writing ##' @export tiledb_group_close <- function(grp) { - stopifnot("The 'grp' argument must be a tiledb_group object" = is(grp, "tiledb_group"), - "This function needs TileDB 2.8.*" = .tiledb28()) - grp@ptr <- libtiledb_group_close(grp@ptr) - grp + stopifnot( + "The 'grp' argument must be a tiledb_group object" = is(grp, "tiledb_group"), + "This function needs TileDB 2.8.*" = .tiledb28() + ) + grp@ptr <- libtiledb_group_close(grp@ptr) + grp } #' Create a TileDB Group at the given path @@ -119,7 +141,9 @@ tiledb_group_close <- function(grp) { #' context object is retrieved #' @return The uri path, invisibly #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' \dontrun{ #' pth <- tempdir() #' tiledb_group_create(pth) @@ -127,231 +151,289 @@ tiledb_group_close <- function(grp) { #' } #' @export tiledb_group_create <- function(uri, ctx = tiledb_get_context()) { - stopifnot("The 'ctx' argument must be a Context object" = is(ctx, "tiledb_ctx"), - "The 'uri' argument must be character" = is.character(uri), - "This function needs TileDB 2.8.*" = .tiledb28()) - libtiledb_group_create(ctx@ptr, uri) - invisible(uri) + stopifnot( + "The 'ctx' argument must be a Context object" = is(ctx, "tiledb_ctx"), + "The 'uri' argument must be character" = is.character(uri), + "This function needs TileDB 2.8.*" = .tiledb28() + ) + libtiledb_group_create(ctx@ptr, uri) + invisible(uri) } ##' Test if TileDB Group is open ##' -##' @param grp A TileDB Group object as for example returned by \code{tiledb_group()} +##' @param grp A TileDB Group object as for example returned by +##' \code{tiledb_group()} ##' @return A boolean indicating whether the TileDB Group object is open ##' @export tiledb_group_is_open <- function(grp) { - stopifnot("The 'grp' argument must be a tiledb_group object" = is(grp, "tiledb_group"), - "This function needs TileDB 2.8.*" = .tiledb28()) - libtiledb_group_is_open(grp@ptr) + stopifnot( + "The 'grp' argument must be a tiledb_group object" = is(grp, "tiledb_group"), + "This function needs TileDB 2.8.*" = .tiledb28() + ) + libtiledb_group_is_open(grp@ptr) } ##' Return a TileDB Group URI ##' -##' @param grp A TileDB Group object as for example returned by \code{tiledb_group()} +##' @param grp A TileDB Group object as for example returned by +##' \code{tiledb_group()} ##' @return A character value with the URI ##' @export tiledb_group_uri <- function(grp) { - stopifnot("The 'grp' argument must be a tiledb_group object" = is(grp, "tiledb_group"), - "This function needs TileDB 2.8.*" = .tiledb28()) - libtiledb_group_uri(grp@ptr) + stopifnot( + "The 'grp' argument must be a tiledb_group object" = is(grp, "tiledb_group"), + "This function needs TileDB 2.8.*" = .tiledb28() + ) + libtiledb_group_uri(grp@ptr) } ##' Return a TileDB Group query type ##' -##' @param grp A TileDB Group object as for example returned by \code{tiledb_group()} -##' @return A character value with the query type i.e. one of \dQuote{READ} or \dQuote{WRITE}. +##' @param grp A TileDB Group object as for example returned by +##' \code{tiledb_group()} +##' @return A character value with the query type i.e. one of +##' \dQuote{READ} or \dQuote{WRITE}. ##' @export tiledb_group_query_type <- function(grp) { - stopifnot("The 'grp' argument must be a tiledb_group object" = is(grp, "tiledb_group"), - "This function needs TileDB 2.8.*" = .tiledb28()) - libtiledb_group_query_type(grp@ptr) + stopifnot( + "The 'grp' argument must be a tiledb_group object" = is(grp, "tiledb_group"), + "This function needs TileDB 2.8.*" = .tiledb28() + ) + libtiledb_group_query_type(grp@ptr) } ##' Write Metadata to a TileDB Group ##' -##' @param grp A TileDB Group object as for example returned by \code{tiledb_group()} -##' @param key A character value with they index under which the data will be written +##' @param grp A TileDB Group object as for example returned by +##' \code{tiledb_group()} +##' @param key A character value with they index under which the +##' data will be written ##' @param val An R object (numeric, int, or char vector) that will be stored ##' @return On success boolean \sQuote{TRUE} is returned ##' @export tiledb_group_put_metadata <- function(grp, key, val) { - stopifnot("The 'grp' argument must be a tiledb_group object" = is(grp, "tiledb_group"), - "The 'key' argument must be character" = is.character(key), - "This function needs TileDB 2.8.*" = .tiledb28()) - libtiledb_group_put_metadata(grp@ptr, key, val) + stopifnot( + "The 'grp' argument must be a tiledb_group object" = is(grp, "tiledb_group"), + "The 'key' argument must be character" = is.character(key), + "This function needs TileDB 2.8.*" = .tiledb28() + ) + libtiledb_group_put_metadata(grp@ptr, key, val) } ##' Deletes Metadata from a TileDB Group ##' -##' @param grp A TileDB Group object as for example returned by \code{tiledb_group()} -##' @param key A character value with they index under which the data will be written +##' @param grp A TileDB Group object as for example returned by +##' \code{tiledb_group()} +##' @param key A character value with they index under which the +##' data will be written ##' @return The TileDB Group object, invisibly ##' @export tiledb_group_delete_metadata <- function(grp, key) { - stopifnot("The 'grp' argument must be a tiledb_group object" = is(grp, "tiledb_group"), - "The 'key' argument must be character" = is.character(key), - "This function needs TileDB 2.8.*" = .tiledb28()) - grp@ptr <- libtiledb_group_delete_metadata(grp@ptr, key) - invisible(grp) + stopifnot( + "The 'grp' argument must be a tiledb_group object" = is(grp, "tiledb_group"), + "The 'key' argument must be character" = is.character(key), + "This function needs TileDB 2.8.*" = .tiledb28() + ) + grp@ptr <- libtiledb_group_delete_metadata(grp@ptr, key) + invisible(grp) } ##' Accesses Metadata from a TileDB Group ##' -##' @param grp A TileDB Group object as for example returned by \code{tiledb_group()} -##' @param key A character value with the key of the metadata object to be retrieved +##' @param grp A TileDB Group object as for example returned by +##' \code{tiledb_group()} +##' @param key A character value with the key of the metadata +##' object to be retrieved ##' @return The requested object, or NULL is not found ##' @export tiledb_group_get_metadata <- function(grp, key) { - stopifnot("The 'grp' argument must be a tiledb_group object" = is(grp, "tiledb_group"), - "The 'key' argument must be character" = is.character(key), - "This function needs TileDB 2.8.*" = .tiledb28()) - libtiledb_group_get_metadata(grp@ptr, key) + stopifnot( + "The 'grp' argument must be a tiledb_group object" = is(grp, "tiledb_group"), + "The 'key' argument must be character" = is.character(key), + "This function needs TileDB 2.8.*" = .tiledb28() + ) + libtiledb_group_get_metadata(grp@ptr, key) } ##' Checks for Metadata in a TileDB Group ##' -##' @param grp A TileDB Group object as for example returned by \code{tiledb_group()} -##' @param key A character value with they index under which the data will be written +##' @param grp A TileDB Group object as for example returned by +##' \code{tiledb_group()} +##' @param key A character value with they index under which the +##' data will be written ##' @return A boolean value indicating with the object is present ##' @export tiledb_group_has_metadata <- function(grp, key) { - stopifnot("The 'grp' argument must be a tiledb_group object" = is(grp, "tiledb_group"), - "The 'key' argument must be character" = is.character(key), - "This function needs TileDB 2.8.*" = .tiledb28()) - libtiledb_group_has_metadata(grp@ptr, key) + stopifnot( + "The 'grp' argument must be a tiledb_group object" = is(grp, "tiledb_group"), + "The 'key' argument must be character" = is.character(key), + "This function needs TileDB 2.8.*" = .tiledb28() + ) + libtiledb_group_has_metadata(grp@ptr, key) } ##' Returns Number of Metadata Objects a TileDB Group ##' -##' @param grp A TileDB Group object as for example returned by \code{tiledb_group()} +##' @param grp A TileDB Group object as for example returned by +##' \code{tiledb_group()} ##' @return A numeric value with the number of metadata objects ##' @export tiledb_group_metadata_num <- function(grp) { - stopifnot("The 'grp' argument must be a tiledb_group object" = is(grp, "tiledb_group"), - "This function needs TileDB 2.8.*" = .tiledb28()) - libtiledb_group_metadata_num(grp@ptr) + stopifnot( + "The 'grp' argument must be a tiledb_group object" = is(grp, "tiledb_group"), + "This function needs TileDB 2.8.*" = .tiledb28() + ) + libtiledb_group_metadata_num(grp@ptr) } ##' Accesses Metadata by Index from a TileDB Group ##' -##' @param grp A TileDB Group object as for example returned by \code{tiledb_group()} +##' @param grp A TileDB Group object as for example returned by +##' \code{tiledb_group()} ##' @param idx A numeric value with the index of the metadata object to be retrieved ##' @return The requested object, or NULL is not found ##' @export tiledb_group_get_metadata_from_index <- function(grp, idx) { - stopifnot("The 'grp' argument must be a tiledb_group object" = is(grp, "tiledb_group"), - "The 'idx' argument must be numeric" = is.numeric(idx), - "This function needs TileDB 2.8.*" = .tiledb28()) - libtiledb_group_get_metadata_from_index(grp@ptr, idx) + stopifnot( + "The 'grp' argument must be a tiledb_group object" = is(grp, "tiledb_group"), + "The 'idx' argument must be numeric" = is.numeric(idx), + "This function needs TileDB 2.8.*" = .tiledb28() + ) + libtiledb_group_get_metadata_from_index(grp@ptr, idx) } ##' Return all Metadata from a TileDB Group ##' -##' @param grp A TileDB Group object as for example returned by \code{tiledb_group()} +##' @param grp A TileDB Group object as for example returned by +##' \code{tiledb_group()} ##' @return A named List with all Metadata objects index ##' @export tiledb_group_get_all_metadata <- function(grp) { - stopifnot("The 'grp' argument must be a tiledb_group object" = is(grp, "tiledb_group"), - "This function needs TileDB 2.8.*" = .tiledb28()) - n <- tiledb_group_metadata_num(grp) - res <- vector(mode="list", length=n) - for (i in seq_len(n)) { - obj <- tiledb_group_get_metadata_from_index(grp, i-1) - res[[i]] <- obj - names(res)[i] <- attr(obj, "key") - } - res + stopifnot( + "The 'grp' argument must be a tiledb_group object" = is(grp, "tiledb_group"), + "This function needs TileDB 2.8.*" = .tiledb28() + ) + n <- tiledb_group_metadata_num(grp) + res <- vector(mode = "list", length = n) + for (i in seq_len(n)) { + obj <- tiledb_group_get_metadata_from_index(grp, i - 1) + res[[i]] <- obj + names(res)[i] <- attr(obj, "key") + } + res } ##' Add Member to TileDB Group ##' -##' @param grp A TileDB Group object as for example returned by \code{tiledb_group()} +##' @param grp A TileDB Group object as for example returned by +##' \code{tiledb_group()} ##' @param uri A character value with a new URI -##' @param relative A logical value indicating whether URI is relative to the group -##' @param name An optional character providing a name for the object, defaults to \code{NULL} +##' @param relative A logical value indicating whether URI is +##' relative to the group +##' @param name An optional character providing a name for the +##' object, defaults to \code{NULL} ##' @return The TileDB Group object, invisibly ##' @export -tiledb_group_add_member <- function(grp, uri, relative, name=NULL) { - stopifnot("The 'grp' argument must be a tiledb_group object" = is(grp, "tiledb_group"), - "The 'uri' argument must be character" = is.character(uri), - "The 'relative' argument must be logical" = is.logical(relative), - "The 'name' argument must be NULL or character" = is.null(name) || is.character(name), - "This function needs TileDB 2.8.*" = .tiledb28()) - grp@ptr <- libtiledb_group_add_member(grp@ptr, uri, relative, name) - invisible(grp) +tiledb_group_add_member <- function(grp, uri, relative, name = NULL) { + stopifnot( + "The 'grp' argument must be a tiledb_group object" = is(grp, "tiledb_group"), + "The 'uri' argument must be character" = is.character(uri), + "The 'relative' argument must be logical" = is.logical(relative), + "The 'name' argument must be NULL or character" = is.null(name) || is.character(name), + "This function needs TileDB 2.8.*" = .tiledb28() + ) + grp@ptr <- libtiledb_group_add_member(grp@ptr, uri, relative, name) + invisible(grp) } ##' Remove Member from TileDB Group ##' -##' @param grp A TileDB Group object as for example returned by \code{tiledb_group()} -##' @param uri A character value with a the URI of the member to be removed, or (if added -##' with a name) the name of the member +##' @param grp A TileDB Group object as for example returned by +##' \code{tiledb_group()} +##' @param uri A character value with a the URI of the member to +##' be removed, or (if added with a name) the name of the member ##' @return The TileDB Group object, invisibly ##' @export tiledb_group_remove_member <- function(grp, uri) { - stopifnot("The 'grp' argument must be a tiledb_group object" = is(grp, "tiledb_group"), - "The 'uri' argument must be character" = is.character(uri), - "This function needs TileDB 2.8.*" = .tiledb28()) - grp@ptr <- libtiledb_group_remove_member(grp@ptr, uri) - invisible(grp) + stopifnot( + "The 'grp' argument must be a tiledb_group object" = is(grp, "tiledb_group"), + "The 'uri' argument must be character" = is.character(uri), + "This function needs TileDB 2.8.*" = .tiledb28() + ) + grp@ptr <- libtiledb_group_remove_member(grp@ptr, uri) + invisible(grp) } ##' Get Member Count from TileDB Group ##' -##' @param grp A TileDB Group object as for example returned by \code{tiledb_group()} +##' @param grp A TileDB Group object as for example returned by +##' \code{tiledb_group()} ##' @return The Count of Members in the TileDB Group object ##' @export tiledb_group_member_count <- function(grp) { - stopifnot("The 'grp' argument must be a tiledb_group object" = is(grp, "tiledb_group"), - "This function needs TileDB 2.8.*" = .tiledb28()) - libtiledb_group_member_count(grp@ptr) + stopifnot( + "The 'grp' argument must be a tiledb_group object" = is(grp, "tiledb_group"), + "This function needs TileDB 2.8.*" = .tiledb28() + ) + libtiledb_group_member_count(grp@ptr) } ##' Get a Member (Description) by Index from TileDB Group ##' -##' This function returns a three-element character vector with the member object translated to -##' character, uri, and optional name. +##' This function returns a three-element character vector with the member +##' object translated to character, uri, and optional name. ##' -##' @param grp A TileDB Group object as for example returned by \code{tiledb_group()} -##' @param idx A numeric value with the index of the metadata object to be retrieved -##' @return A character vector with three elements: the member type, its uri, and name -##' (or \code{""} if the member is unnamed). +##' @param grp A TileDB Group object as for example returned by +##' \code{tiledb_group()} +##' @param idx A numeric value with the index of the metadata +##' object to be retrieved +##' @return A character vector with three elements: the member +##' type, its uri, and name (or \code{""} if the member is unnamed). ##' @export tiledb_group_member <- function(grp, idx) { - stopifnot("The 'grp' argument must be a tiledb_group object" = is(grp, "tiledb_group"), - "The 'idx' argument must be numeric" = is.numeric(idx), - "This function needs TileDB 2.8.*" = .tiledb28()) - libtiledb_group_member(grp@ptr, idx) + stopifnot( + "The 'grp' argument must be a tiledb_group object" = is(grp, "tiledb_group"), + "The 'idx' argument must be numeric" = is.numeric(idx), + "This function needs TileDB 2.8.*" = .tiledb28() + ) + libtiledb_group_member(grp@ptr, idx) } ##' Dump the TileDB Group to String ##' -##' @param grp A TileDB Group object as for example returned by \code{tiledb_group()} -##' @param recursive A logical value indicating whether a recursive dump is desired, defaults -##' to \sQuote{FALSE}. Note that recursive listings on remote object may be an expensive or -##' slow operation. +##' @param grp A TileDB Group object as for example returned by +##' \code{tiledb_group()} +##' @param recursive A logical value indicating whether a recursive +##' dump is desired, defaults to \sQuote{FALSE}. Note that recursive listings +##' on remote object may be an expensive or slow operation. ##' @return A character string ##' @export tiledb_group_member_dump <- function(grp, recursive = FALSE) { - stopifnot("The 'grp' argument must be a tiledb_group object" = is(grp, "tiledb_group"), - "This function needs TileDB 2.8.*" = .tiledb28()) - libtiledb_group_dump(grp@ptr, recursive) + stopifnot( + "The 'grp' argument must be a tiledb_group object" = is(grp, "tiledb_group"), + "This function needs TileDB 2.8.*" = .tiledb28() + ) + libtiledb_group_dump(grp@ptr, recursive) } ##' Test if a Named Group is Using a Relative URI ##' -##' @param grp A TileDB Group object as for example returned by \code{tiledb_group()} +##' @param grp A TileDB Group object as for example returned by +##' \code{tiledb_group()} ##' @param name A character value with a group name ##' @return A boolean indicating whether the group uses a relative URI or not ##' @export tiledb_group_is_relative <- function(grp, name) { - stopifnot("The 'grp' argument must be a tiledb_group object" = is(grp, "tiledb_group"), - "The 'name' argument must be a character variable" = inherits(name, "character"), - "This function needs TileDB 2.12.*" = tiledb_version(TRUE) >= "2.12.0") - libtiledb_group_is_relative(grp@ptr, name) + stopifnot( + "The 'grp' argument must be a tiledb_group object" = is(grp, "tiledb_group"), + "The 'name' argument must be a character variable" = inherits(name, "character"), + "This function needs TileDB 2.12.*" = tiledb_version(TRUE) >= "2.12.0" + ) + libtiledb_group_is_relative(grp@ptr, name) } #' Display the TileDB Group object to STDOUT @@ -359,26 +441,29 @@ tiledb_group_is_relative <- function(grp, name) { #' @param object `tiledb_group` object #' @export setMethod("show", signature(object = "tiledb_group"), function(object) { - cat(libtiledb_group_dump(object@ptr, FALSE)) + cat(libtiledb_group_dump(object@ptr, FALSE)) }) #' Deletes all written data from a 'tiledb_group' object #' -#' The group must be opened in \sQuote{MODIFY_EXCLUSIVE} mode, otherwise the function -#' will error out. +#' The group must be opened in \sQuote{MODIFY_EXCLUSIVE} mode, otherwise +#' the function will error out. #' -#' @param grp A TileDB Group object as for example returned by \code{tiledb_group()} +#' @param grp A TileDB Group object as for example returned by +#' \code{tiledb_group()} #' @param uri Character variable with the URI of the group item to be deleted -#' @param recursive A logical value indicating whether all data iniside the -#' group is to be delet +#' @param recursive A logical value indicating whether all data inside the +#' group is to be deleted #' @return Nothing is returned, the function is invoked for the side-effect of #' group data removal. #' @export tiledb_group_delete <- function(grp, uri, recursive = FALSE) { - stopifnot("The 'grp' argument must be a tiledb_group object" = is(grp, "tiledb_group"), - "The 'uri' argument must be a character variable" = inherits(uri, "character"), - "The 'recursive' argument be logical" = is(recursive, "logical"), - "This function needs TileDB 2.14.*" = tiledb_version(TRUE) >= "2.14.0") - libtiledb_group_delete(grp@ptr, uri, isTRUE(recursive)) + stopifnot( + "The 'grp' argument must be a tiledb_group object" = is(grp, "tiledb_group"), + "The 'uri' argument must be a character variable" = inherits(uri, "character"), + "The 'recursive' argument be logical" = is(recursive, "logical"), + "This function needs TileDB 2.14.*" = tiledb_version(TRUE) >= "2.14.0" + ) + libtiledb_group_delete(grp@ptr, uri, isTRUE(recursive)) } diff --git a/R/Init.R b/R/Init.R index c13015097f..3cb0894dba 100644 --- a/R/Init.R +++ b/R/Init.R @@ -23,108 +23,114 @@ .pkgenv <- new.env(parent = emptyenv()) .defaultConfigFile <- function() { - if (getRversion() >= "4.0.0") { - ## ~/.local/share/R/ + package - pkgdir <- tools::R_user_dir(packageName()) - if (dir.exists(pkgdir)) { - fname <- file.path(pkgdir, "config.dcf") - if (file.exists(fname)) { - return(fname) - } - } + if (getRversion() >= "4.0.0") { + ## ~/.local/share/R/ + package + pkgdir <- tools::R_user_dir(packageName()) + if (dir.exists(pkgdir)) { + fname <- file.path(pkgdir, "config.dcf") + if (file.exists(fname)) { + return(fname) + } } - return("") + } + return("") } .onLoad <- function(libname, pkgname) { - ## create a slot for ctx in the per-package enviroment but do no fill it yet to allow 'lazy load' - ## this entry is generally accessed with a (non-exported) getter and setter in R/Ctx.R - .pkgenv[["ctx"]] <- NULL + ## create a slot for ctx in the per-package enviroment but do no fill it yet to allow 'lazy load' + ## this entry is generally accessed with a (non-exported) getter and setter in R/Ctx.R + .pkgenv[["ctx"]] <- NULL - ## similarly, use a slot for the vfs object - .pkgenv[["vfs"]] <- NULL + ## similarly, use a slot for the vfs object + .pkgenv[["vfs"]] <- NULL - ## cache query status of last finalized query - .pkgenv[["query_status"]] <- character() + ## cache query status of last finalized query + .pkgenv[["query_status"]] <- character() - ## set a preference for data.frame conversion for tiledb_array and [] access - .pkgenv[["return_as"]] <- load_return_as_preference() + ## set a preference for data.frame conversion for tiledb_array and [] access + .pkgenv[["return_as"]] <- load_return_as_preference() - ## set a preference for allocation size defaults - .pkgenv[["allocation_size"]] <- load_allocation_size_preference() + ## set a preference for allocation size defaults + .pkgenv[["allocation_size"]] <- load_allocation_size_preference() - ## call setter for Rcpp plugin support - .set_compile_link_options() + ## call setter for Rcpp plugin support + .set_compile_link_options() - lib_path <- system.file("lib", .Platform$r_arch, paste0("libconnection", .Platform$dynlib.ext), package = "tiledb") - res <- dyn.load(lib_path) - .Call(`_tiledb_tldb_init_`, res$new_connection$address, PACKAGE="tiledb") + lib_path <- system.file("lib", .Platform$r_arch, paste0("libconnection", .Platform$dynlib.ext), package = "tiledb") + res <- dyn.load(lib_path) + .Call(`_tiledb_tldb_init_`, res$new_connection$address, PACKAGE = "tiledb") } .onUnload <- function(libname) { - lib_path <- system.file("lib", .Platform$r_arch, paste0("libconnection", .Platform$dynlib.ext), package = "tiledb") - dyn.unload(lib_path) + lib_path <- system.file("lib", .Platform$r_arch, paste0("libconnection", .Platform$dynlib.ext), package = "tiledb") + dyn.unload(lib_path) } .onAttach <- function(libname, pkgname) { - if (interactive()) { - packageStartupMessage("TileDB R ", packageVersion("tiledb"), - " with TileDB Embedded ", format(tiledb_version(TRUE)), - " on ", utils::osVersion, - ".\nSee https://tiledb.com for more information about TileDB.") - } + if (interactive()) { + packageStartupMessage( + "TileDB R ", packageVersion("tiledb"), + " with TileDB Embedded ", format(tiledb_version(TRUE)), + " on ", utils::osVersion, + ".\nSee https://tiledb.com for more information about TileDB." + ) + } } ## this uses an interface offered by the Rcpp package which, when seeing 'Rcpp::depends(pkgname)' ## will look for a pkgname::inlineCxxPlugin callback to learn about compile + link options inlineCxxPlugin <- function(...) { - txt <- paste("No TileDB system-wide installation found. Consider setting TILEDB_INSTALL_DIR", - "if have you an installation.") - stopifnot(txt = .pkgenv[["tiledb_ldflag"]] != "") - plugin <- Rcpp::Rcpp.plugin.maker(include.before = "#include ", - libs = .pkgenv[["tiledb_ldflag"]], - package = "tiledb", - Makevars = NULL, - Makevars.win = NULL) - settings <- plugin() - settings$env$PKG_CPPFLAGS <- .pkgenv[["tiledb_cppflag"]] - settings + txt <- paste( + "No TileDB system-wide installation found. Consider setting TILEDB_INSTALL_DIR", + "if have you an installation." + ) + stopifnot(txt = .pkgenv[["tiledb_ldflag"]] != "") + plugin <- Rcpp::Rcpp.plugin.maker( + include.before = "#include ", + libs = .pkgenv[["tiledb_ldflag"]], + package = "tiledb", + Makevars = NULL, + Makevars.win = NULL + ) + settings <- plugin() + settings$env$PKG_CPPFLAGS <- .pkgenv[["tiledb_cppflag"]] + settings } ## find library and header directories from either an env var, or pkg-config ## used only by the Rcpp 'plugin' facilitating quick experimentation with short C++ files .set_compile_link_options <- function(cppflag, ldflag) { - if (missing(cppflag) && missing(ldflag)) { - pkgcfg <- unname(Sys.which("pkg-config")) - have_tiledb_pkgcfg <- isTRUE(Sys.info()[["sysname"]] != "Windows" && - pkgcfg != "" && - system2(pkgcfg, c("tiledb", "--exists")) == 0) - if ((tiledb <- Sys.getenv("TILEDB_INSTALL_DIR", "")) != "") { - .pkgenv[["tiledb_cppflag"]] <- sprintf("-I%s/include", tiledb) - .pkgenv[["tiledb_ldflag"]] <- sprintf("-L%s -ltiledb", tiledb) - } else if (have_tiledb_pkgcfg) { - .pkgenv[["tiledb_cppflag"]] <- system2(pkgcfg, c("tiledb", "--cflags"), stdout = TRUE) - .pkgenv[["tiledb_ldflag"]] <- system2(pkgcfg, c("tiledb", "--libs"), stdout = TRUE) - } else { - .pkgenv[["tiledb_cppflag"]] <- "" - .pkgenv[["tiledb_ldflag"]] <- "" - } + if (missing(cppflag) && missing(ldflag)) { + pkgcfg <- unname(Sys.which("pkg-config")) + have_tiledb_pkgcfg <- isTRUE(Sys.info()[["sysname"]] != "Windows" && + pkgcfg != "" && + system2(pkgcfg, c("tiledb", "--exists")) == 0) + if ((tiledb <- Sys.getenv("TILEDB_INSTALL_DIR", "")) != "") { + .pkgenv[["tiledb_cppflag"]] <- sprintf("-I%s/include", tiledb) + .pkgenv[["tiledb_ldflag"]] <- sprintf("-L%s -ltiledb", tiledb) + } else if (have_tiledb_pkgcfg) { + .pkgenv[["tiledb_cppflag"]] <- system2(pkgcfg, c("tiledb", "--cflags"), stdout = TRUE) + .pkgenv[["tiledb_ldflag"]] <- system2(pkgcfg, c("tiledb", "--libs"), stdout = TRUE) } else { - .pkgenv[["tiledb_cppflag"]] <- cppflag - .pkgenv[["tiledb_ldflag"]] <- ldflag + .pkgenv[["tiledb_cppflag"]] <- "" + .pkgenv[["tiledb_ldflag"]] <- "" } + } else { + .pkgenv[["tiledb_cppflag"]] <- cppflag + .pkgenv[["tiledb_ldflag"]] <- ldflag + } } #' @importFrom utils read.table .getLinuxFlavor <- function() { - res <- NA_character_ - osrel <- "/etc/os-release" - if (isTRUE(file.exists(osrel))) { # on (at least) Debian, Ubuntu, Fedora - x <- read.table(osrel, sep="=", row.names=1, col.names=c("","Val"), header = FALSE) - res <- x["ID", "Val"] - } - res + res <- NA_character_ + osrel <- "/etc/os-release" + if (isTRUE(file.exists(osrel))) { # on (at least) Debian, Ubuntu, Fedora + x <- read.table(osrel, sep = "=", row.names = 1, col.names = c("", "Val"), header = FALSE) + res <- x["ID", "Val"] + } + res } .isFedora <- function() isTRUE(.getLinuxFlavor() == "fedora") diff --git a/R/Matrix.R b/R/Matrix.R index 475408922e..0a559489d5 100644 --- a/R/Matrix.R +++ b/R/Matrix.R @@ -34,55 +34,61 @@ ##' @return Null, invisibly. ##' ##' @export -fromMatrix <- function(obj, - uri, - filter="ZSTD", - capacity = 10000L) { +fromMatrix <- function( + obj, + uri, + filter = "ZSTD", + capacity = 10000L +) { + stopifnot( + `Argument 'obj' must be matrix object` = inherits(obj, "matrix"), + `Argument 'uri' must be character` = is.character(uri) + ) - stopifnot(`Argument 'obj' must be matrix object` = inherits(obj, "matrix"), - `Argument 'uri' must be character` = is.character(uri)) + dims <- dim(obj) + dimnm <- dimnames(obj) + hasnames <- !is.null(dimnm) && !is.null(dimnm[[1]]) && !is.null(dimnm[[2]]) + if (hasnames) { + dimr <- tiledb_dim(name = "rows", type = "ASCII", tile = NULL, domain = c(NULL, NULL)) + dimc <- tiledb_dim(name = "cols", type = "ASCII", tile = NULL, domain = c(NULL, NULL)) + dom <- tiledb_domain(dims = c(dimr, dimc)) + } else { + dimr <- tiledb_dim(name = "rows", type = "INT32", tile = dims[1], domain = c(1L, dims[1])) + dimc <- tiledb_dim(name = "cols", type = "INT32", tile = dims[2], domain = c(1L, dims[2])) + dom <- tiledb_domain(dims = c(dimr, dimc)) + } - dims <- dim(obj) - dimnm <- dimnames(obj) - hasnames <- !is.null(dimnm) && !is.null(dimnm[[1]]) && !is.null(dimnm[[2]]) - if (hasnames) { - dimr <- tiledb_dim(name="rows", type = "ASCII", tile = NULL, domain = c(NULL, NULL)) - dimc <- tiledb_dim(name="cols", type = "ASCII", tile = NULL, domain = c(NULL, NULL)) - dom <- tiledb_domain(dims = c(dimr, dimc)) - } else { - dimr <- tiledb_dim(name="rows", type = "INT32", tile = dims[1], domain = c(1L, dims[1])) - dimc <- tiledb_dim(name="cols", type = "INT32", tile = dims[2], domain = c(1L, dims[2])) - dom <- tiledb_domain(dims = c(dimr, dimc)) - } + cl <- class(obj[1, 1]) + if (cl == "integer") { + tp <- "INT32" + } else if (cl == "numeric") { + tp <- "FLOAT64" + } else { + stop("Currently unsupported type: ", cl) + } - cl <- class(obj[1,1]) - if (cl == "integer") - tp <- "INT32" - else if (cl == "numeric") - tp <- "FLOAT64" - else - stop("Currently unsupported type: ", cl) + filterlist <- tiledb_filter_list(sapply(filter, tiledb_filter)) - filterlist <- tiledb_filter_list(sapply(filter, tiledb_filter)) - - attx <- tiledb_attr(name="x", type = tp, ncells = 1, filter_list = filterlist) - schema <- tiledb_array_schema(dom, attrs=attx, sparse = hasnames, capacity=capacity) - tiledb_array_create(uri, schema) - arr <- tiledb_array(uri) - if (hasnames) { - df <- data.frame(rows = rep(dimnm[[1]], dims[2]), - cols = rep(dimnm[[2]], each=dims[1]), - x = as.vector(obj)) - arr[] <- df - } else { - arr[] <- obj - } - invisible(NULL) + attx <- tiledb_attr(name = "x", type = tp, ncells = 1, filter_list = filterlist) + schema <- tiledb_array_schema(dom, attrs = attx, sparse = hasnames, capacity = capacity) + tiledb_array_create(uri, schema) + arr <- tiledb_array(uri) + if (hasnames) { + df <- data.frame( + rows = rep(dimnm[[1]], dims[2]), + cols = rep(dimnm[[2]], each = dims[1]), + x = as.vector(obj) + ) + arr[] <- df + } else { + arr[] <- obj + } + invisible(NULL) } ##' @rdname fromMatrix ##' @export toMatrix <- function(uri) { - stopifnot(`Argument 'uri' must be character` = is.character(uri)) - tiledb_array(uri, return_as="matrix")[] + stopifnot(`Argument 'uri' must be character` = is.character(uri)) + tiledb_array(uri, return_as = "matrix")[] } diff --git a/R/Metadata.R b/R/Metadata.R index 1df55aae86..c9feaa8ca4 100644 --- a/R/Metadata.R +++ b/R/Metadata.R @@ -28,9 +28,11 @@ ##' metdata of the given array ##' @export tiledb_has_metadata <- function(arr, key) { - stopifnot(`Argument 'arr' must be a (dense or sparse) TileDB array` = .isArray(arr), - `Argument 'key' must be a scalar character` = is.scalar(key, "character"), - `Array must be open for reading to access metadata` = libtiledb_array_is_open_for_reading(arr@ptr)) + stopifnot( + `Argument 'arr' must be a (dense or sparse) TileDB array` = .isArray(arr), + `Argument 'key' must be a scalar character` = is.scalar(key, "character"), + `Array must be open for reading to access metadata` = libtiledb_array_is_open_for_reading(arr@ptr) + ) res <- libtiledb_array_get_metadata_list(arr@ptr) key %in% names(res) } @@ -41,8 +43,10 @@ tiledb_has_metadata <- function(arr, key) { ##' @return A integer variable with the number of Metadata objects ##' @export tiledb_num_metadata <- function(arr) { - stopifnot(`Argument 'arr' must be a (dense or sparse) TileDB array` = .isArray(arr), - `Array must be open for reading to access metadata` = libtiledb_array_is_open_for_reading(arr@ptr)) + stopifnot( + `Argument 'arr' must be a (dense or sparse) TileDB array` = .isArray(arr), + `Array must be open for reading to access metadata` = libtiledb_array_is_open_for_reading(arr@ptr) + ) libtiledb_array_get_metadata_num(arr@ptr) } @@ -54,13 +58,16 @@ tiledb_num_metadata <- function(arr) { ##' or \sQuote{NULL} if none found. ##' @export tiledb_get_metadata <- function(arr, key) { - stopifnot(`Argument 'arr' must be a (dense or sparse) TileDB array` = .isArray(arr), - `Array must be open for reading to access metadata` = libtiledb_array_is_open_for_reading(arr@ptr)) + stopifnot( + `Argument 'arr' must be a (dense or sparse) TileDB array` = .isArray(arr), + `Array must be open for reading to access metadata` = libtiledb_array_is_open_for_reading(arr@ptr) + ) res <- libtiledb_array_get_metadata_list(arr@ptr) - if (key %in% names(res)) + if (key %in% names(res)) { res[[key]] - else + } else { NULL + } } ##' Store an object in TileDB Array Metadata under given key @@ -71,9 +78,11 @@ tiledb_get_metadata <- function(arr, key) { ##' @return A boolean value indicating success ##' @export tiledb_put_metadata <- function(arr, key, val) { - stopifnot(`Argument must be a (dense or sparse) TileDB array.` = .isArray(arr), - `Array is not open for writing.` = libtiledb_array_is_open_for_writing(arr@ptr)) - libtiledb_array_put_metadata(arr@ptr, key, val) + stopifnot( + `Argument must be a (dense or sparse) TileDB array.` = .isArray(arr), + `Array is not open for writing.` = libtiledb_array_is_open_for_writing(arr@ptr) + ) + libtiledb_array_put_metadata(arr@ptr, key, val) } @@ -83,8 +92,10 @@ tiledb_put_metadata <- function(arr, key, val) { ##' @return A named list with all Metadata objects indexed by the given key ##' @export tiledb_get_all_metadata <- function(arr) { - stopifnot(`Argument 'arr' must be a (dense or sparse) TileDB array` = .isArray(arr), - `Array must be open for reading to access metadata` = libtiledb_array_is_open_for_reading(arr@ptr)) + stopifnot( + `Argument 'arr' must be a (dense or sparse) TileDB array` = .isArray(arr), + `Array must be open for reading to access metadata` = libtiledb_array_is_open_for_reading(arr@ptr) + ) res <- libtiledb_array_get_metadata_list(arr@ptr) class(res) <- "tiledb_metadata" res @@ -98,10 +109,10 @@ tiledb_get_all_metadata <- function(arr) { ##' @return The array object, invisibly ##' @export ##' @method print tiledb_metadata -print.tiledb_metadata <- function(x, width=NULL, ...) { +print.tiledb_metadata <- function(x, width = NULL, ...) { nm <- names(x) for (i in 1:length(nm)) { - cat(nm[i], ":\t", format(x[i]), "\n", sep="") + cat(nm[i], ":\t", format(x[i]), "\n", sep = "") } invisible(x) } @@ -113,8 +124,10 @@ print.tiledb_metadata <- function(x, width=NULL, ...) { ##' @return A boolean indicating success ##' @export tiledb_delete_metadata <- function(arr, key) { - stopifnot(`Argument must be a (dense or sparse) TileDB array.` = .isArray(arr), - `Array is not open for writing.` = libtiledb_array_is_open_for_writing(arr@ptr)) + stopifnot( + `Argument must be a (dense or sparse) TileDB array.` = .isArray(arr), + `Array is not open for writing.` = libtiledb_array_is_open_for_writing(arr@ptr) + ) libtiledb_array_delete_metadata(arr@ptr, key) - TRUE # we get NULL from C++ + TRUE # we get NULL from C++ } diff --git a/R/NDRectangle.R b/R/NDRectangle.R index 9d175f46d8..66449c9d14 100644 --- a/R/NDRectangle.R +++ b/R/NDRectangle.R @@ -25,7 +25,8 @@ #' @slot ptr An external pointer to the underlying NDRectangle object #' @exportClass tiledb_ndrectangle setClass("tiledb_ndrectangle", - slots = list(ptr = "externalptr")) + slots = list(ptr = "externalptr") +) #' Creates a `tiledb_ndrectangle` object #' @@ -33,19 +34,23 @@ setClass("tiledb_ndrectangle", #' @param ctx (optional) A TileDB Ctx object #' @return The `tiledb_ndrectangle` object #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' if (tiledb_version(TRUE) >= "2.25.0") { -#' dom <-tiledb_domain(dim = tiledb_dim("d1", c(1L, 100L), type = "INT32")) -#' ndr <- tiledb_ndrectangle(dom) +#' dom <- tiledb_domain(dim = tiledb_dim("d1", c(1L, 100L), type = "INT32")) +#' ndr <- tiledb_ndrectangle(dom) #' } #' #' @export tiledb_ndrectangle <- function(dom, ctx = tiledb_get_context()) { - stopifnot("The first argument must be a TileDB Domain object" = is(dom, "tiledb_domain"), - "The second argment must be a TileDB Ctx object" = is(ctx, "tiledb_ctx"), - "This function needs TileDB 2.25.0 or later" = tiledb_version(TRUE) >= "2.25.0") - ptr <- libtiledb_ndrectangle_create(ctx@ptr, dom@ptr) - return(new("tiledb_ndrectangle", ptr = ptr)) + stopifnot( + "The first argument must be a TileDB Domain object" = is(dom, "tiledb_domain"), + "The second argment must be a TileDB Ctx object" = is(ctx, "tiledb_ctx"), + "This function needs TileDB 2.25.0 or later" = tiledb_version(TRUE) >= "2.25.0" + ) + ptr <- libtiledb_ndrectangle_create(ctx@ptr, dom@ptr) + return(new("tiledb_ndrectangle", ptr = ptr)) } #' Set a range on a `tiledb_ndrectangle` object @@ -60,24 +65,28 @@ tiledb_ndrectangle <- function(dom, ctx = tiledb_get_context()) { #' dimension. The set of allowed type includes the different integer types as well as #' string dimensions. #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' if (tiledb_version(TRUE) >= "2.26.0") { -#' dom <-tiledb_domain(dim = tiledb_dim("d1", c(1L, 100L), type = "INT32")) -#' ndr <- tiledb_ndrectangle(dom) -#' ndr <- tiledb_ndrectangle_set_range(ndr, "d1", 50, 500) +#' dom <- tiledb_domain(dim = tiledb_dim("d1", c(1L, 100L), type = "INT32")) +#' ndr <- tiledb_ndrectangle(dom) +#' ndr <- tiledb_ndrectangle_set_range(ndr, "d1", 50, 500) #' } #' @export tiledb_ndrectangle_set_range <- function(ndr, dimname, start, end) { - stopifnot("The first argument must be a TileDB NDRectangle object" = is(ndr, "tiledb_ndrectangle"), - "The second argument must a single character object" = is.character(dimname) && - length(dimname) == 1, - "The third argument must be scalar" = length(start) == 1, - "The fourth argument must be scalar" = length(end) == 1, - "The fourth and first argument must be of the same class" = class(start) == class(end), - "This function needs TileDB 2.26.0 or later" = tiledb_version(TRUE) >= "2.26.0") - dtype <- libtiledb_ndrectangle_datatype(ndr@ptr, dimname) - ndr@ptr <- libtiledb_ndrectangle_set_range(ndr@ptr, dtype, dimname, start, end) - invisible(ndr) + stopifnot( + "The first argument must be a TileDB NDRectangle object" = is(ndr, "tiledb_ndrectangle"), + "The second argument must a single character object" = is.character(dimname) && + length(dimname) == 1, + "The third argument must be scalar" = length(start) == 1, + "The fourth argument must be scalar" = length(end) == 1, + "The fourth and first argument must be of the same class" = class(start) == class(end), + "This function needs TileDB 2.26.0 or later" = tiledb_version(TRUE) >= "2.26.0" + ) + dtype <- libtiledb_ndrectangle_datatype(ndr@ptr, dimname) + ndr@ptr <- libtiledb_ndrectangle_set_range(ndr@ptr, dtype, dimname, start, end) + invisible(ndr) } #' Get a range from a `tiledb_ndrectangle` object @@ -86,22 +95,26 @@ tiledb_ndrectangle_set_range <- function(ndr, dimname, start, end) { #' @param dimname A character variable with the dimension for which to get a range #' @return The `tiledb_ndrectangle` range as a two-element vector #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' if (tiledb_version(TRUE) >= "2.26.0") { -#' dom <- tiledb_domain(dim = tiledb_dim("d1", c(1L, 100L), type = "INT32")) -#' ndr <- tiledb_ndrectangle(dom) -#' ndr <- tiledb_ndrectangle_set_range(ndr, "d1", 50, 500) -#' tiledb_ndrectangle_get_range(ndr, "d1") +#' dom <- tiledb_domain(dim = tiledb_dim("d1", c(1L, 100L), type = "INT32")) +#' ndr <- tiledb_ndrectangle(dom) +#' ndr <- tiledb_ndrectangle_set_range(ndr, "d1", 50, 500) +#' tiledb_ndrectangle_get_range(ndr, "d1") #' } #' @export tiledb_ndrectangle_get_range <- function(ndr, dimname) { - stopifnot("The first argument must be a TileDB NDRectangle object" = is(ndr, "tiledb_ndrectangle"), - "The second argument must a single character object" = is.character(dimname) && - length(dimname) == 1, - "This function needs TileDB 2.26.0 or later" = tiledb_version(TRUE) >= "2.26.0") - dtype <- libtiledb_ndrectangle_datatype(ndr@ptr, dimname) - rng <- libtiledb_ndrectangle_get_range(ndr@ptr, dimname, dtype) - rng + stopifnot( + "The first argument must be a TileDB NDRectangle object" = is(ndr, "tiledb_ndrectangle"), + "The second argument must a single character object" = is.character(dimname) && + length(dimname) == 1, + "This function needs TileDB 2.26.0 or later" = tiledb_version(TRUE) >= "2.26.0" + ) + dtype <- libtiledb_ndrectangle_datatype(ndr@ptr, dimname) + rng <- libtiledb_ndrectangle_get_range(ndr@ptr, dimname, dtype) + rng } #' Get the number of dimensions for `tiledb_ndrectangle` object @@ -109,17 +122,21 @@ tiledb_ndrectangle_get_range <- function(ndr, dimname) { #' @param ndr A TileDB NDRectangle object #' @return The number of dimentiones for the `tiledb_ndrectangle` #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' if (tiledb_version(TRUE) >= "2.26.0") { -#' dom <- tiledb_domain(dim = tiledb_dim("d1", c(1L, 100L), type = "INT32")) -#' ndr <- tiledb_ndrectangle(dom) -#' tiledb_ndrectangle_dim_num(ndr) +#' dom <- tiledb_domain(dim = tiledb_dim("d1", c(1L, 100L), type = "INT32")) +#' ndr <- tiledb_ndrectangle(dom) +#' tiledb_ndrectangle_dim_num(ndr) #' } #' @export tiledb_ndrectangle_dim_num <- function(ndr) { - stopifnot("The argument must be a TileDB NDRectangle object" = is(ndr, "tiledb_ndrectangle"), - "This function needs TileDB 2.26.0 or later" = tiledb_version(TRUE) >= "2.26.0") - libtiledb_ndrectangle_dim_num(ndr@ptr) + stopifnot( + "The argument must be a TileDB NDRectangle object" = is(ndr, "tiledb_ndrectangle"), + "This function needs TileDB 2.26.0 or later" = tiledb_version(TRUE) >= "2.26.0" + ) + libtiledb_ndrectangle_dim_num(ndr@ptr) } #' Get the datatype of a named `tiledb_ndrectangle` dimension @@ -128,19 +145,23 @@ tiledb_ndrectangle_dim_num <- function(ndr) { #' @param dimname A character variable with the dimension for which to get a datatype #' @return The `tiledb_ndrectangle` dimension datatype as a character #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' if (tiledb_version(TRUE) >= "2.26.0") { -#' dom <- tiledb_domain(dim = tiledb_dim("d1", c(1L, 100L), type = "INT32")) -#' ndr <- tiledb_ndrectangle(dom) -#' tiledb_ndrectangle_datatype(ndr, "d1") +#' dom <- tiledb_domain(dim = tiledb_dim("d1", c(1L, 100L), type = "INT32")) +#' ndr <- tiledb_ndrectangle(dom) +#' tiledb_ndrectangle_datatype(ndr, "d1") #' } #' @export tiledb_ndrectangle_datatype <- function(ndr, dimname) { - stopifnot("The first argument must be a TileDB NDRectangle object" = is(ndr, "tiledb_ndrectangle"), - "The second argument must a single character object" = is.character(dimname) && - length(dimname) == 1, - "This function needs TileDB 2.26.0 or later" = tiledb_version(TRUE) >= "2.26.0") - libtiledb_ndrectangle_datatype(ndr@ptr, dimname) + stopifnot( + "The first argument must be a TileDB NDRectangle object" = is(ndr, "tiledb_ndrectangle"), + "The second argument must a single character object" = is.character(dimname) && + length(dimname) == 1, + "This function needs TileDB 2.26.0 or later" = tiledb_version(TRUE) >= "2.26.0" + ) + libtiledb_ndrectangle_datatype(ndr@ptr, dimname) } #' Get the datatype of a `tiledb_ndrectangle` dimension by index @@ -149,17 +170,21 @@ tiledb_ndrectangle_datatype <- function(ndr, dimname) { #' @param dim Am integer value for the dimension for which to get a datatype #' @return The `tiledb_ndrectangle` dimension datatype as a character #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' if (tiledb_version(TRUE) >= "2.26.0") { -#' dom <- tiledb_domain(dim = tiledb_dim("d1", c(1L, 100L), type = "INT32")) -#' ndr <- tiledb_ndrectangle(dom) -#' tiledb_ndrectangle_datatype_by_ind(ndr, 0) +#' dom <- tiledb_domain(dim = tiledb_dim("d1", c(1L, 100L), type = "INT32")) +#' ndr <- tiledb_ndrectangle(dom) +#' tiledb_ndrectangle_datatype_by_ind(ndr, 0) #' } #' @export tiledb_ndrectangle_datatype_by_ind <- function(ndr, dim) { - stopifnot("The first argument must be a TileDB NDRectangle object" = is(ndr, "tiledb_ndrectangle"), - "The second argument must a single numeric object" = is.numeric(dim) && - length(dim) == 1, - "This function needs TileDB 2.26.0 or later" = tiledb_version(TRUE) >= "2.26.0") - libtiledb_ndrectangle_datatype_by_ind(ndr@ptr, dim) + stopifnot( + "The first argument must be a TileDB NDRectangle object" = is(ndr, "tiledb_ndrectangle"), + "The second argument must a single numeric object" = is.numeric(dim) && + length(dim) == 1, + "This function needs TileDB 2.26.0 or later" = tiledb_version(TRUE) >= "2.26.0" + ) + libtiledb_ndrectangle_datatype_by_ind(ndr@ptr, dim) } diff --git a/R/Object.R b/R/Object.R index dd28f8f4bb..21975da340 100644 --- a/R/Object.R +++ b/R/Object.R @@ -33,10 +33,12 @@ #' #' @export tiledb_object_type <- function(uri, ctx = tiledb_get_context()) { - stopifnot("The 'ctx' argument must be a tiledb_ctx" = is(ctx, "tiledb_ctx"), - "The 'uri' argument must be a string scalar" = - !missing(uri) && is.scalar(uri,"character")) - libtiledb_object_type(ctx@ptr, uri) + stopifnot( + "The 'ctx' argument must be a tiledb_ctx" = is(ctx, "tiledb_ctx"), + "The 'uri' argument must be a string scalar" = + !missing(uri) && is.scalar(uri, "character") + ) + libtiledb_object_type(ctx@ptr, uri) } #' Removes a TileDB resource @@ -48,10 +50,12 @@ tiledb_object_type <- function(uri, ctx = tiledb_get_context()) { #' @return uri of removed TileDB resource #' @export tiledb_object_rm <- function(uri, ctx = tiledb_get_context()) { - stopifnot("The 'ctx' argument must be a tiledb_ctx" = is(ctx, "tiledb_ctx"), - "The 'uri' argument must be a string scalar" = - !missing(uri) && is.scalar(uri,"character")) - libtiledb_object_remove(ctx@ptr, uri) + stopifnot( + "The 'ctx' argument must be a tiledb_ctx" = is(ctx, "tiledb_ctx"), + "The 'uri' argument must be a string scalar" = + !missing(uri) && is.scalar(uri, "character") + ) + libtiledb_object_remove(ctx@ptr, uri) } #' Move a TileDB resource to new uri path @@ -64,10 +68,12 @@ tiledb_object_rm <- function(uri, ctx = tiledb_get_context()) { #' @return new uri of moved tiledb resource #' @export tiledb_object_mv <- function(old_uri, new_uri, ctx = tiledb_get_context()) { - stopifnot("The 'ctx' argument must be a tiledb_ctx" = is(ctx, "tiledb_ctx"), - "The 'old_uri' argument must be a string scalar" = !missing(old_uri) && is.scalar(old_uri,"character"), - "The 'new_uri' argument must be a string scalar" = !missing(new_uri) && is.scalar(new_uri,"character")) - libtiledb_object_move(ctx@ptr, old_uri, new_uri) + stopifnot( + "The 'ctx' argument must be a tiledb_ctx" = is(ctx, "tiledb_ctx"), + "The 'old_uri' argument must be a string scalar" = !missing(old_uri) && is.scalar(old_uri, "character"), + "The 'new_uri' argument must be a string scalar" = !missing(new_uri) && is.scalar(new_uri, "character") + ) + libtiledb_object_move(ctx@ptr, old_uri, new_uri) } #' List TileDB resources at a given root URI path @@ -78,10 +84,12 @@ tiledb_object_mv <- function(old_uri, new_uri, ctx = tiledb_get_context()) { #' @return a dataframe with object type, object uri string columns #' @export tiledb_object_ls <- function(uri, filter = NULL, ctx = tiledb_get_context()) { - stopifnot("The 'ctx' argument must be a tiledb_ctx" = is(ctx, "tiledb_ctx"), - "The 'uri' argument must be a string scalar" = - !missing(uri) && is.scalar(uri,"character")) - libtiledb_object_walk(ctx@ptr, uri, order = "PREORDER") + stopifnot( + "The 'ctx' argument must be a tiledb_ctx" = is(ctx, "tiledb_ctx"), + "The 'uri' argument must be a string scalar" = + !missing(uri) && is.scalar(uri, "character") + ) + libtiledb_object_walk(ctx@ptr, uri, order = "PREORDER") } #' Recursively discover TileDB resources at a given root URI path @@ -92,10 +100,12 @@ tiledb_object_ls <- function(uri, filter = NULL, ctx = tiledb_get_context()) { #' @return a dataframe with object type, object uri string columns #' @export tiledb_object_walk <- function(uri, order = c("PREORDER", "POSTORDER"), ctx = tiledb_get_context()) { - order <- match.arg(order) - stopifnot("The 'ctx' argument must be a tiledb_ctx" = is(ctx, "tiledb_ctx"), - "The 'order' argument must be a string scalar" = is.scalar(order,"character"), - "The 'uri' argument must be a string scalar" = - !missing(uri) && is.scalar(uri,"character")) - libtiledb_object_walk(ctx@ptr, uri, order = order, recursive = TRUE) + order <- match.arg(order) + stopifnot( + "The 'ctx' argument must be a tiledb_ctx" = is(ctx, "tiledb_ctx"), + "The 'order' argument must be a string scalar" = is.scalar(order, "character"), + "The 'uri' argument must be a string scalar" = + !missing(uri) && is.scalar(uri, "character") + ) + libtiledb_object_walk(ctx@ptr, uri, order = order, recursive = TRUE) } diff --git a/R/Query.R b/R/Query.R index 22c03d0116..7c532204a3 100644 --- a/R/Query.R +++ b/R/Query.R @@ -25,10 +25,11 @@ #' @slot ptr An external pointer to the underlying implementation #' @exportClass tiledb_query setClass("tiledb_query", - slots = list(ptr = "externalptr")) - ## arr = "ANY")) - ## could add arr of type 'ANY' (using shortcut to not have to deal with collate order) - ## if array was needed for query object + slots = list(ptr = "externalptr") +) +## arr = "ANY")) +## could add arr of type 'ANY' (using shortcut to not have to deal with collate order) +## if array was needed for query object #' Creates a 'tiledb_query' object #' @@ -38,12 +39,15 @@ setClass("tiledb_query", #' @param ctx (optional) A TileDB Ctx object #' @return 'tiledb_query' object #' @export tiledb_query -tiledb_query <- function(array, - type = if (tiledb_version(TRUE) >= "2.12.0") - c("READ", "WRITE", "DELETE", "MODIFY_EXCLUSIVE") - else - c("READ", "WRITE"), - ctx = tiledb_get_context()) { +tiledb_query <- function( + array, + type = if (tiledb_version(TRUE) >= "2.12.0") { + c("READ", "WRITE", "DELETE", "MODIFY_EXCLUSIVE") + } else { + c("READ", "WRITE") + }, + ctx = tiledb_get_context() +) { stopifnot(`Argument 'arr' must be a tiledb_array object` = .isArray(array)) type <- match.arg(type) array <- tiledb_array_open(array, type) @@ -69,8 +73,13 @@ tiledb_query_type <- function(query) { #' "COL_MAJOR", "ROW_MAJOR", "GLOBAL_ORDER", "UNORDERED") #' @return The modified query object, invisibly #' @export -tiledb_query_set_layout <- function(query, layout=c("COL_MAJOR", "ROW_MAJOR", - "GLOBAL_ORDER", "UNORDERED")) { +tiledb_query_set_layout <- function( + query, + layout = c( + "COL_MAJOR", "ROW_MAJOR", + "GLOBAL_ORDER", "UNORDERED" + ) +) { stopifnot(`Argument 'query' must be a tiledb_query object` = is(query, "tiledb_query")) layout <- match.arg(layout) libtiledb_query_set_layout(query@ptr, layout) @@ -117,16 +126,18 @@ tiledb_query_set_subarray <- function(query, subarray, type) { #' @return The modified query object, invisisibly #' @export tiledb_query_set_buffer <- function(query, attr, buffer) { - stopifnot(`Argument 'query' must be a tiledb_query object` = is(query, "tiledb_query"), - `Argument 'attr' must be character_variable` = is.character(attr), - `Argument 'buffer' must be integer, numeric or logical` = is.numeric(buffer) || is.logical(buffer)) + stopifnot( + `Argument 'query' must be a tiledb_query object` = is(query, "tiledb_query"), + `Argument 'attr' must be character_variable` = is.character(attr), + `Argument 'buffer' must be integer, numeric or logical` = is.numeric(buffer) || is.logical(buffer) + ) if (is.numeric(buffer) || tiledb_version(TRUE) < "2.10.0") { - libtiledb_query_set_buffer(query@ptr, attr, buffer) - } else { # logical now maps to BOOL which is a uint8_t, we need a different approach - nr <- NROW(buffer) - bufptr <- libtiledb_query_buffer_alloc_ptr("BOOL", nr, FALSE, 1) - bufptr <- libtiledb_query_buffer_assign_ptr(bufptr, "BOOL", buffer, FALSE) - query@ptr <- libtiledb_query_set_buffer_ptr(query@ptr, attr, bufptr) + libtiledb_query_set_buffer(query@ptr, attr, buffer) + } else { # logical now maps to BOOL which is a uint8_t, we need a different approach + nr <- NROW(buffer) + bufptr <- libtiledb_query_buffer_alloc_ptr("BOOL", nr, FALSE, 1) + bufptr <- libtiledb_query_buffer_assign_ptr(bufptr, "BOOL", buffer, FALSE) + query@ptr <- libtiledb_query_set_buffer_ptr(query@ptr, attr, bufptr) } invisible(query) } @@ -138,8 +149,10 @@ tiledb_query_set_buffer <- function(query, attr, buffer) { #' @return An external pointer to the allocated buffer object #' @export tiledb_query_create_buffer_ptr_char <- function(query, varvec) { - stopifnot("Argument 'query' must be a tiledb_query object" = is(query, "tiledb_query"), - "Argument 'varvec' must be a character vector" = is.vector(varvec) && is.character(varvec)) + stopifnot( + "Argument 'query' must be a tiledb_query object" = is(query, "tiledb_query"), + "Argument 'varvec' must be a character vector" = is.vector(varvec) && is.character(varvec) + ) bufptr <- libtiledb_query_buffer_var_char_create(varvec, TRUE) bufptr } @@ -151,9 +164,15 @@ tiledb_query_create_buffer_ptr_char <- function(query, varvec) { #' @param nullable An optional boolean indicating whether the column can have NULLs #' @return An external pointer to the allocated buffer object #' @export -tiledb_query_alloc_buffer_ptr_char <- function(sizeoffsets, sizedata, nullable=FALSE) { - stopifnot(`Argument 'sizeoffset' must be numeric` = is.numeric(sizeoffsets), - `Argument 'sizedata' must be numeric` = is.numeric(sizedata)) +tiledb_query_alloc_buffer_ptr_char <- function( + sizeoffsets, + sizedata, + nullable = FALSE +) { + stopifnot( + `Argument 'sizeoffset' must be numeric` = is.numeric(sizeoffsets), + `Argument 'sizedata' must be numeric` = is.numeric(sizedata) + ) bufptr <- libtiledb_query_buffer_var_char_alloc_direct(sizeoffsets, sizedata, nullable) bufptr } @@ -185,12 +204,13 @@ tiledb_query_alloc_buffer_ptr_char <- function(sizeoffsets, sizedata, nullable=F #' @return The modified query object, invisibly #' @export tiledb_query_set_buffer_ptr_char <- function(query, attr, bufptr) { - stopifnot(`Argument 'query' must be a tiledb_query object` = is(query, "tiledb_query"), - `Argument 'attr' must be a character object` = is.character(attr), - `Argument 'bufptr' must be an external pointer` = is(bufptr, "externalptr")) + stopifnot( + `Argument 'query' must be a tiledb_query object` = is(query, "tiledb_query"), + `Argument 'attr' must be a character object` = is.character(attr), + `Argument 'bufptr' must be an external pointer` = is(bufptr, "externalptr") + ) libtiledb_query_set_buffer_var_char(query@ptr, attr, bufptr) invisible(query) - } #' Allocate a Query buffer for a given type @@ -205,12 +225,20 @@ tiledb_query_set_buffer_ptr_char <- function(query, attr, bufptr) { #' default is one #' @return An external pointer to the allocated buffer object #' @export -tiledb_query_buffer_alloc_ptr <- function(query, datatype, ncells, nullable=FALSE, varnum=1) { - stopifnot("Argument 'query' must be a tiledb_query object" = is(query, "tiledb_query"), - "Argument 'datatype' must be a character object" = is.character(datatype), - "Argument 'ncells' must be numeric" = is.numeric(ncells), - "Argument 'nullable' must be logical" = is.logical(nullable), - "Argument 'varnum' must be integer or numeric" = is.integer(varnum) || is.numeric(varnum)) +tiledb_query_buffer_alloc_ptr <- function( + query, + datatype, + ncells, + nullable = FALSE, + varnum = 1 +) { + stopifnot( + "Argument 'query' must be a tiledb_query object" = is(query, "tiledb_query"), + "Argument 'datatype' must be a character object" = is.character(datatype), + "Argument 'ncells' must be numeric" = is.numeric(ncells), + "Argument 'nullable' must be logical" = is.logical(nullable), + "Argument 'varnum' must be integer or numeric" = is.integer(varnum) || is.numeric(varnum) + ) bufptr <- libtiledb_query_buffer_alloc_ptr(datatype, ncells, nullable, varnum) bufptr } @@ -225,9 +253,11 @@ tiledb_query_buffer_alloc_ptr <- function(query, datatype, ncells, nullable=FALS #' @return An external pointer to the allocated buffer object #' @export tiledb_query_create_buffer_ptr <- function(query, datatype, object) { - stopifnot(`Argument 'query' must be a tiledb_query object` = is(query, "tiledb_query"), - #`Argument 'object' must be a vector` = is.vector(object), - `Argument 'datatype' must be a character object` = is.character(datatype)) + stopifnot( + `Argument 'query' must be a tiledb_query object` = is(query, "tiledb_query"), + # `Argument 'object' must be a vector` = is.vector(object), + `Argument 'datatype' must be a character object` = is.character(datatype) + ) ncells <- length(object) bufptr <- libtiledb_query_buffer_alloc_ptr(datatype, ncells) bufptr <- libtiledb_query_buffer_assign_ptr(bufptr, datatype, object) @@ -243,9 +273,11 @@ tiledb_query_create_buffer_ptr <- function(query, datatype, object) { #' @return The modified query object, invisibly #' @export tiledb_query_set_buffer_ptr <- function(query, attr, bufptr) { - stopifnot(`Argument 'query' must be a tiledb_query object` = is(query, "tiledb_query"), - `Argument 'attr' must be a character object` = is.character(attr), - `Argument 'bufptr' must be an external pointer` = is(bufptr, "externalptr")) + stopifnot( + `Argument 'query' must be a tiledb_query object` = is(query, "tiledb_query"), + `Argument 'attr' must be a character object` = is.character(attr), + `Argument 'bufptr' must be an external pointer` = is(bufptr, "externalptr") + ) libtiledb_query_set_buffer_ptr(query@ptr, attr, bufptr) invisible(query) } @@ -270,7 +302,11 @@ tiledb_query_get_buffer_ptr <- function(bufptr) { #' @param sizestring An optional argument for the length of the internal string #' @return An R object as resulting from the query #' @export -tiledb_query_get_buffer_char <- function(bufptr, sizeoffsets=0, sizestring=0) { +tiledb_query_get_buffer_char <- function( + bufptr, + sizeoffsets = 0, + sizestring = 0 +) { stopifnot(`Argument 'bufptr' must be an external pointer` = is(bufptr, "externalptr")) libtiledb_query_get_buffer_var_char(bufptr, sizeoffsets, sizestring) } @@ -299,7 +335,7 @@ tiledb_query_submit <- function(query) { tiledb_query_submit_async <- function(query) { stopifnot("Argument 'query' must be a tiledb_query object" = is(query, "tiledb_query")) ## Deprecated April 2024, to be removed April 2025 or later - .Deprecated(msg="tiledb_query_submit_async() is deprecated, use tiledb_query_submit() instead.") + .Deprecated(msg = "tiledb_query_submit_async() is deprecated, use tiledb_query_submit() instead.") libtiledb_query_submit_async(query@ptr) invisible(query) } @@ -345,8 +381,10 @@ tiledb_query_status <- function(query) { #' @seealso tiledb_query_result_buffer_elements_vec #' @export tiledb_query_result_buffer_elements <- function(query, attr) { - stopifnot(`Argument 'query' must be a tiledb_query object` = is(query, "tiledb_query"), - `Argument 'attr' must be a character object` = is.character(attr)) + stopifnot( + `Argument 'query' must be a tiledb_query object` = is(query, "tiledb_query"), + `Argument 'attr' must be a character object` = is.character(attr) + ) libtiledb_query_result_buffer_elements(query@ptr, attr, 1) # request 2nd el in pair } @@ -371,10 +409,16 @@ tiledb_query_result_buffer_elements <- function(query, attr) { #' buffer size. #' @seealso tiledb_query_result_buffer_elements #' @export -tiledb_query_result_buffer_elements_vec <- function(query, attr, nullable = FALSE) { - stopifnot(`Argument 'query' must be a tiledb_query object` = is(query, "tiledb_query"), - `Argument 'attr' must be a character object` = is.character(attr), - `Argument 'nullable' must be a logical` = is.logical(nullable)) +tiledb_query_result_buffer_elements_vec <- function( + query, + attr, + nullable = FALSE +) { + stopifnot( + `Argument 'query' must be a tiledb_query object` = is(query, "tiledb_query"), + `Argument 'attr' must be a character object` = is.character(attr), + `Argument 'nullable' must be a logical` = is.logical(nullable) + ) libtiledb_query_result_buffer_elements_vec(query@ptr, attr, nullable) } @@ -388,17 +432,25 @@ tiledb_query_result_buffer_elements_vec <- function(query, attr, nullable = FALS #' @param stride An optional stride value for the range to be set #' @return The query object, invisibly #' @export -tiledb_query_add_range <- function(query, schema, attr, lowval, highval, stride=NULL) { - stopifnot(`Argument 'query' must be a tiledb_query object` = is(query, "tiledb_query"), - `Argument 'schema' must be a tiledb_array_schema object` = is(schema, "tiledb_array_schema"), - `Argument 'attr' must be a character object` = is.character(attr), - `Argument 'lowval' must be numeric` = is.numeric(lowval), - `Argument 'highval' must be numeric` = is.numeric(highval), - `Argument 'stride' must be numeric (or NULL)` = is.null(stride) || is.numeric(lowval)) +tiledb_query_add_range <- function( + query, + schema, + attr, lowval, + highval, + stride = NULL +) { + stopifnot( + `Argument 'query' must be a tiledb_query object` = is(query, "tiledb_query"), + `Argument 'schema' must be a tiledb_array_schema object` = is(schema, "tiledb_array_schema"), + `Argument 'attr' must be a character object` = is.character(attr), + `Argument 'lowval' must be numeric` = is.numeric(lowval), + `Argument 'highval' must be numeric` = is.numeric(highval), + `Argument 'stride' must be numeric (or NULL)` = is.null(stride) || is.numeric(lowval) + ) names <- tiledb_schema_get_names(schema) types <- tiledb_schema_get_types(schema) idx <- which(names == attr) - query <- tiledb_query_add_range_with_type(query, idx-1L, types[idx], lowval, highval, stride) + query <- tiledb_query_add_range_with_type(query, idx - 1L, types[idx], lowval, highval, stride) invisible(query) } @@ -412,13 +464,22 @@ tiledb_query_add_range <- function(query, schema, attr, lowval, highval, stride= #' @param stride An optional stride value for the range to be set #' @return The query object, invisibly #' @export -tiledb_query_add_range_with_type <- function(query, idx, datatype, lowval, highval, stride=NULL) { - stopifnot(`Argument 'query' must be a tiledb_query object` = is(query, "tiledb_query"), - `Argument 'idx' must be integer` = is.integer(idx), - `Argument 'datatype' must be character` = is.character(datatype), - `Argument 'lowval' must be numeric` = is.numeric(lowval), - `Argument 'highval' must be numeric` = is.numeric(highval), - `Argument 'stride' must be numeric (or NULL)` = is.null(stride) || is.numeric(lowval)) +tiledb_query_add_range_with_type <- function( + query, + idx, + datatype, + lowval, + highval, + stride = NULL +) { + stopifnot( + `Argument 'query' must be a tiledb_query object` = is(query, "tiledb_query"), + `Argument 'idx' must be integer` = is.integer(idx), + `Argument 'datatype' must be character` = is.character(datatype), + `Argument 'lowval' must be numeric` = is.numeric(lowval), + `Argument 'highval' must be numeric` = is.numeric(highval), + `Argument 'stride' must be numeric (or NULL)` = is.null(stride) || is.numeric(lowval) + ) ## The (initial) Query member function is deprecated, we now use a subarray sbrptr <- libtiledb_subarray(query@ptr) sbrptr <- libtiledb_subarray_add_range_with_type(sbrptr, idx, datatype, lowval, highval, stride) @@ -446,8 +507,10 @@ tiledb_query_get_fragment_num <- function(query) { #' @return An character value with the fragment URI #' @export tiledb_query_get_fragment_uri <- function(query, idx) { - stopifnot(`Argument 'query' must be a tiledb_query object` = is(query, "tiledb_query"), - `Argument 'idx' must be numeric` = is.numeric(idx)) + stopifnot( + `Argument 'query' must be a tiledb_query object` = is(query, "tiledb_query"), + `Argument 'idx' must be numeric` = is.numeric(idx) + ) libtiledb_query_get_fragment_uri(query@ptr, idx) } @@ -460,8 +523,10 @@ tiledb_query_get_fragment_uri <- function(query, idx) { #' @return A two-element datetime vector with the start and end time of the fragment write. #' @export tiledb_query_get_fragment_timestamp_range <- function(query, idx) { - stopifnot(`Argument 'query' must be a tiledb_query object` = is(query, "tiledb_query"), - `Argument 'idx' must be numeric` = is.numeric(idx)) + stopifnot( + `Argument 'query' must be a tiledb_query object` = is(query, "tiledb_query"), + `Argument 'idx' must be numeric` = is.numeric(idx) + ) libtiledb_query_get_fragment_timestamp_range(query@ptr, idx) } @@ -478,8 +543,10 @@ tiledb_query_get_fragment_timestamp_range <- function(query, idx) { #' @return An estimate of the query result size #' @export tiledb_query_get_est_result_size <- function(query, name) { - stopifnot(`Argument 'query' must be a tiledb_query object` = is(query, "tiledb_query"), - `Argument 'name' must be character` = is.character(name)) + stopifnot( + `Argument 'query' must be a tiledb_query object` = is(query, "tiledb_query"), + `Argument 'name' must be character` = is.character(name) + ) libtiledb_query_get_est_result_size(query@ptr, name) } @@ -495,8 +562,10 @@ tiledb_query_get_est_result_size <- function(query, name) { #' @return An estimate of the query result size #' @export tiledb_query_get_est_result_size_var <- function(query, name) { - stopifnot(`Argument 'query' must be a tiledb_query object` = is(query, "tiledb_query"), - `Argument 'name' must be character` = is.character(name)) + stopifnot( + `Argument 'query' must be a tiledb_query object` = is(query, "tiledb_query"), + `Argument 'name' must be character` = is.character(name) + ) libtiledb_query_get_est_result_size_var(query@ptr, name) } @@ -508,9 +577,11 @@ tiledb_query_get_est_result_size_var <- function(query, name) { #' given dimensions #' @export tiledb_query_get_range_num <- function(query, idx) { - stopifnot(`Argument 'query' must be a tiledb_query object` = is(query, "tiledb_query"), - `Argument 'idx' must be numeric` = is.numeric(idx)) - libtiledb_query_get_range_num(query@ptr, idx-1) + stopifnot( + `Argument 'query' must be a tiledb_query object` = is(query, "tiledb_query"), + `Argument 'idx' must be numeric` = is.numeric(idx) + ) + libtiledb_query_get_range_num(query@ptr, idx - 1) } #' Retrieve the query range for a query dimension and range index @@ -522,10 +593,12 @@ tiledb_query_get_range_num <- function(query, idx) { #' range for the given dimension and range index #' @export tiledb_query_get_range <- function(query, dimidx, rngidx) { - stopifnot(`Argument 'query' must be a tiledb_query object` = is(query, "tiledb_query"), - `Argument 'dimidx' must be numeric` = is.numeric(dimidx), - `Argument 'rngidx' must be numeric` = is.numeric(rngidx)) - libtiledb_query_get_range(query@ptr, dimidx-1, rngidx-1) + stopifnot( + `Argument 'query' must be a tiledb_query object` = is(query, "tiledb_query"), + `Argument 'dimidx' must be numeric` = is.numeric(dimidx), + `Argument 'rngidx' must be numeric` = is.numeric(rngidx) + ) + libtiledb_query_get_range(query@ptr, dimidx - 1, rngidx - 1) } #' Retrieve the query range for a variable-sized query dimension and range index @@ -537,10 +610,12 @@ tiledb_query_get_range <- function(query, dimidx, rngidx) { #' range for the given dimension and range index #' @export tiledb_query_get_range_var <- function(query, dimidx, rngidx) { - stopifnot(`Argument 'query' must be a tiledb_query object` = is(query, "tiledb_query"), - `Argument 'dimidx' must be numeric` = is.numeric(dimidx), - `Argument 'rngidx' must be numeric` = is.numeric(rngidx)) - libtiledb_query_get_range_var(query@ptr, dimidx-1, rngidx-1) + stopifnot( + `Argument 'query' must be a tiledb_query object` = is(query, "tiledb_query"), + `Argument 'dimidx' must be numeric` = is.numeric(dimidx), + `Argument 'rngidx' must be numeric` = is.numeric(rngidx) + ) + libtiledb_query_get_range_var(query@ptr, dimidx - 1, rngidx - 1) } #' Set a query combination object for a query @@ -550,10 +625,12 @@ tiledb_query_get_range_var <- function(query, dimidx, rngidx) { #' @return The modified query object, invisibly #' @export tiledb_query_set_condition <- function(query, qc) { - stopifnot(`Argument 'query' must be a tiledb_query object` = is(query, "tiledb_query"), - `Argument 'qc' must be a query_condition object` = is(qc, "tiledb_query_condition")) - query@ptr <- libtiledb_query_set_condition(query@ptr, qc@ptr) - invisible(query) + stopifnot( + `Argument 'query' must be a tiledb_query object` = is(query, "tiledb_query"), + `Argument 'qc' must be a query_condition object` = is(qc, "tiledb_query_condition") + ) + query@ptr <- libtiledb_query_set_condition(query@ptr, qc@ptr) + invisible(query) } #' Retrieve the cached status of the last finalized query @@ -564,7 +641,7 @@ tiledb_query_set_condition <- function(query, qc) { #' @return The status of the last query #' @export tiledb_get_query_status <- function() { - .pkgenv[["query_status"]] + .pkgenv[["query_status"]] } #' Return query statistics as a JSON string @@ -573,8 +650,8 @@ tiledb_get_query_status <- function() { #' @return A JSON-formatted string with context statistics #' @export tiledb_query_stats <- function(query) { - stopifnot(`The 'query' argument must be a TileDB Query object` = is(query, "tiledb_query")) - libtiledb_query_stats(query@ptr) + stopifnot(`The 'query' argument must be a TileDB Query object` = is(query, "tiledb_query")) + libtiledb_query_stats(query@ptr) } #' Return query context object @@ -583,8 +660,8 @@ tiledb_query_stats <- function(query) { #' @return A TileDB Context object retrieved from the query #' @export tiledb_query_ctx <- function(query) { - stopifnot(`The 'query' argument must be a TileDB Query object` = is(query, "tiledb_query")) - new("tiledb_ctx", ptr = libtiledb_query_get_ctx(query@ptr)) + stopifnot(`The 'query' argument must be a TileDB Query object` = is(query, "tiledb_query")) + new("tiledb_ctx", ptr = libtiledb_query_get_ctx(query@ptr)) } ## The next function could be used to extract an 'tiledb_array' object from a query object @@ -595,10 +672,10 @@ tiledb_query_ctx <- function(query) { # ' @param query A TileDB Query object # ' @return A TileDB Array object retrieved from the query # ' @ export -#tiledb_query_array <- function(query) { +# tiledb_query_array <- function(query) { # stopifnot(`The 'query' must be a TileDB Query object` = is(query, "tiledb_query")) # query@arr -#} +# } ##' Run an aggregate oprtation on the given query attribute ##' @@ -608,14 +685,18 @@ tiledb_query_ctx <- function(query) { ##' @param nullable A boolean toggle whether the attribute is nullable ##' @return The value of the aggregation ##' @export -tiledb_query_apply_aggregate <- function(query, attrname, - operation = c("Count", "NullCount", "Min", "Max", - "Mean", "Sum"), - nullable = TRUE) { - stopifnot("The 'query' argument must be a TileDB Query object" = is(query, "tiledb_query"), - "The 'attrname' argument must be character" = is.character(attrname), - "The 'operation' argument must be character" = is.character(operation), - "The 'nullable' argument must be logical" = is.logical(nullable)) - operation <- match.arg(operation) - libtiledb_query_apply_aggregate(query@ptr, attrname, operation, nullable) +tiledb_query_apply_aggregate <- function( + query, + attrname, + operation = c("Count", "NullCount", "Min", "Max", "Mean", "Sum"), + nullable = TRUE +) { + stopifnot( + "The 'query' argument must be a TileDB Query object" = is(query, "tiledb_query"), + "The 'attrname' argument must be character" = is.character(attrname), + "The 'operation' argument must be character" = is.character(operation), + "The 'nullable' argument must be logical" = is.logical(nullable) + ) + operation <- match.arg(operation) + libtiledb_query_apply_aggregate(query@ptr, attrname, operation, nullable) } diff --git a/R/QueryCondition.R b/R/QueryCondition.R index d59578a618..31c3e3d604 100644 --- a/R/QueryCondition.R +++ b/R/QueryCondition.R @@ -27,8 +27,11 @@ #' initialized #' @exportClass tiledb_query_condition setClass("tiledb_query_condition", - slots = list(ptr = "externalptr", - init = "logical")) + slots = list( + ptr = "externalptr", + init = "logical" + ) +) #' Creates a 'tiledb_query_condition' object #' @@ -37,10 +40,10 @@ setClass("tiledb_query_condition", #' @return A 'tiledb_query_condition' object #' @export tiledb_query_condition <- function(ctx = tiledb_get_context()) { - stopifnot("The argument must be a ctx object" = is(ctx, "tiledb_ctx")) - ptr <- libtiledb_query_condition(ctx@ptr) - query_condition <- new("tiledb_query_condition", ptr = ptr, init = FALSE) - invisible(query_condition) + stopifnot("The argument must be a ctx object" = is(ctx, "tiledb_ctx")) + ptr <- libtiledb_query_condition(ctx@ptr) + query_condition <- new("tiledb_query_condition", ptr = ptr, init = FALSE) + invisible(query_condition) } #' Initialize a 'tiledb_query_condition' object @@ -60,23 +63,25 @@ tiledb_query_condition <- function(ctx = tiledb_get_context()) { #' @return The initialized 'tiledb_query_condition' object #' @export tiledb_query_condition_init <- function(attr, value, dtype, op, qc = tiledb_query_condition()) { - stopifnot("Argument 'qc' with query condition object required" = inherits(qc, "tiledb_query_condition"), - "Argument 'attr' must be character" = is.character(attr), - "Argument 'value' must be of length one" = (is.vector(value) || - bit64::is.integer64(value) || - inherits(value, "POSIXt") || - inherits(value, "Date")) && all.equal(length(value),1), - "Argument 'dtype' must be character" = is.character(dtype), - "Argument 'op' must be character" = is.character(op)) - op <- match.arg(op, c("LT", "LE", "GT", "GE", "EQ", "NE")) - ## if dtype is INT64 or UINT64 but the class of value does not yet inherit from integer64, cast - if (grepl("INT64", dtype) && !inherits(value, "integer64")) { - value <- bit64::as.integer64(value) - #message("QCI ", attr, ", ", value, ", ", class(value)[1], ", ", dtype, ", ", op) - } - libtiledb_query_condition_init(qc@ptr, attr, value, dtype, op) - qc@init <- TRUE - invisible(qc) + stopifnot( + "Argument 'qc' with query condition object required" = inherits(qc, "tiledb_query_condition"), + "Argument 'attr' must be character" = is.character(attr), + "Argument 'value' must be of length one" = (is.vector(value) || + bit64::is.integer64(value) || + inherits(value, "POSIXt") || + inherits(value, "Date")) && all.equal(length(value), 1), + "Argument 'dtype' must be character" = is.character(dtype), + "Argument 'op' must be character" = is.character(op) + ) + op <- match.arg(op, c("LT", "LE", "GT", "GE", "EQ", "NE")) + ## if dtype is INT64 or UINT64 but the class of value does not yet inherit from integer64, cast + if (grepl("INT64", dtype) && !inherits(value, "integer64")) { + value <- bit64::as.integer64(value) + # message("QCI ", attr, ", ", value, ", ", class(value)[1], ", ", dtype, ", ", op) + } + libtiledb_query_condition_init(qc@ptr, attr, value, dtype, op) + qc@init <- TRUE + invisible(qc) } #' Combine two 'tiledb_query_condition' objects @@ -90,14 +95,16 @@ tiledb_query_condition_init <- function(attr, value, dtype, op, qc = tiledb_quer #' @return The combined 'tiledb_query_condition' object #' @export tiledb_query_condition_combine <- function(lhs, rhs, op) { - stopifnot("Argument 'lhs' must be a query condition object" = is(lhs, "tiledb_query_condition"), - "Argument 'rhs' must be a query condition object" = is(rhs, "tiledb_query_condition"), - "Argument 'op' must be a character" = is.character(op)) - op <- match.arg(op, c("AND", "OR", "NOT")) - qc <- tiledb_query_condition() - qc@ptr <- libtiledb_query_condition_combine(lhs@ptr, rhs@ptr, op) - qc@init <- TRUE - invisible(qc) + stopifnot( + "Argument 'lhs' must be a query condition object" = is(lhs, "tiledb_query_condition"), + "Argument 'rhs' must be a query condition object" = is(rhs, "tiledb_query_condition"), + "Argument 'op' must be a character" = is.character(op) + ) + op <- match.arg(op, c("AND", "OR", "NOT")) + qc <- tiledb_query_condition() + qc@ptr <- libtiledb_query_condition_combine(lhs@ptr, rhs@ptr, op) + qc@init <- TRUE + invisible(qc) } #' Create a 'tiledb_query_condition' object from an expression @@ -125,144 +132,175 @@ tiledb_query_condition_combine <- function(lhs, rhs, op) { #' default is false to remain as a default four-byte \code{int} #' @return A `tiledb_query_condition` object #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' \dontrun{ -#' uri <- "mem://airquality" # change to on-disk for persistence -#' fromDataFrame(airquality, uri, col_index=c("Month", "Day")) # dense array +#' uri <- "mem://airquality" # change to on-disk for persistence +#' fromDataFrame(airquality, uri, col_index = c("Month", "Day")) # dense array #' ## query condition on dense array requires extended=FALSE -#' tiledb_array(uri, return_as="data.frame", extended=FALSE, -#' query_condition=parse_query_condition(Temp > 90))[] +#' tiledb_array(uri, +#' return_as = "data.frame", extended = FALSE, +#' query_condition = parse_query_condition(Temp > 90) +#' )[] #' } #' @export -parse_query_condition <- function(expr, ta=NULL, debug=FALSE, strict=TRUE, use_int64=FALSE) { - .hasArray <- !is.null(ta) && is(ta, "tiledb_array") - if (.hasArray && length(ta@sil) == 0) ta@sil <- .fill_schema_info_list(ta@uri) - `%!in%` <- Negate(`%in%`) - .isComparisonOperator <- function(x) tolower(as.character(x)) %in% c(">", ">=", "<", "<=", "==", "!=", "%in%", "%nin%") - .isBooleanOperator <- function(x) as.character(x) %in% c("&&", "||", "!", "&", "|") - .isAscii <- function(x) grepl("^[[:alnum:]_]+$", x) - .isInteger <- function(x) grepl("^[[:digit:]]+$", as.character(x)) - .isDouble <- function(x) grepl("^[[:digit:]\\.]+$", as.character(x)) && length(grepRaw(".", as.character(x), fixed = TRUE, all = TRUE)) == 1 - .isInOperator <- function(x) tolower(as.character(x)) %in% c("%in%", "%nin%") - .errorFunction <- if (strict) stop else warning - .getInd <- function(attr, ta) { - if (isFALSE(.hasArray)) stop("The 'ta' argument is required for this type of parse", call. = FALSE) +parse_query_condition <- function(expr, ta = NULL, debug = FALSE, strict = TRUE, use_int64 = FALSE) { + .hasArray <- !is.null(ta) && is(ta, "tiledb_array") + if (.hasArray && length(ta@sil) == 0) ta@sil <- .fill_schema_info_list(ta@uri) + `%!in%` <- Negate(`%in%`) + .isComparisonOperator <- function(x) tolower(as.character(x)) %in% c(">", ">=", "<", "<=", "==", "!=", "%in%", "%nin%") + .isBooleanOperator <- function(x) as.character(x) %in% c("&&", "||", "!", "&", "|") + .isAscii <- function(x) grepl("^[[:alnum:]_]+$", x) + .isInteger <- function(x) grepl("^[[:digit:]]+$", as.character(x)) + .isDouble <- function(x) grepl("^[[:digit:]\\.]+$", as.character(x)) && length(grepRaw(".", as.character(x), fixed = TRUE, all = TRUE)) == 1 + .isInOperator <- function(x) tolower(as.character(x)) %in% c("%in%", "%nin%") + .errorFunction <- if (strict) stop else warning + .getInd <- function(attr, ta) { + if (isFALSE(.hasArray)) stop("The 'ta' argument is required for this type of parse", call. = FALSE) + ind <- match(attr, ta@sil$names) + if (!is.finite(ind)) { + .errorFunction("No attribute '", attr, "' present.", call. = FALSE) + return(NULL) + } + if (ta@sil$status[ind] != 2) { + .errorFunction("Argument '", attr, "' is not an attribute.", call. = FALSE) + return(NULL) + } + ind + } + .getType <- function(x, tp, use_int64 = FALSE) { + if (.hasArray) { + ind <- .getInd(tp, ta) + dtype <- ta@sil$types[ind] + return(dtype) + } + if (isTRUE(.isInteger(x))) { + if (use_int64) "INT64" else "INT32" + } else if (isTRUE(.isDouble(x))) { + "FLOAT64" + } else { + "ASCII" + } + } + .mapOpToCharacter <- function(x) { + switch(x, + `>` = "GT", + `>=` = "GE", + `<` = "LT", + `<=` = "LE", + `==` = "EQ", + `!=` = "NE" + ) + } + .mapBoolToCharacter <- function(x) { + switch(x, + `&&` = "AND", + `&` = "AND", + `||` = "OR", + `|` = "OR", + `!` = "NOT" + ) + } + .neweqcond <- function(val, attr) { + if (debug) cat(" ", attr, "EQ", val, "\n") + tiledb_query_condition_init(attr = attr, value = val, dtype = "ASCII", op = "EQ") + } + .neworcond <- function(op1, op2) tiledb_query_condition_combine(op1, op2, "OR") + .makeExpr <- function(x, debug = FALSE) { + if (is.symbol(x)) { + stop("Unexpected symbol in expression: ", format(x)) + } else if (x[[1]] == "(") { + if (debug) cat("-- [(", as.character(x[2]), ")]\n", sep = "") + .makeExpr(x[[2]]) + } else if (.isBooleanOperator(x[1])) { + if (debug) { + cat("-- [", as.character(x[2]), "]", + " ", as.character(x[1]), + " [", as.character(x[3]), "]\n", + sep = "" + ) + } + .makeExpr(x[[2]], debug = debug) + .makeExpr(x[[3]], debug = debug) + tiledb_query_condition_combine( + .makeExpr(x[[2]]), + .makeExpr(x[[3]]), + .mapBoolToCharacter(as.character(x[1])) + ) + } else if (.isInOperator(x[1])) { + if (debug) { + cat("in: [", as.character(x[2]), "]", + " ", as.character(x[1]), + " [", as.character(x[3]), "]\n", + sep = "" + ) + } + attr <- as.character(x[2]) + op <- tolower(as.character(x[1])) + tdbop <- if (op == "%in%") "IN" else "NOT_IN" + ind <- .getInd(attr, ta) + dtype <- ta@sil$types[ind] + is_enum <- ta@sil$enum[ind] + vals <- eval(parse(text = as.character(x[3]))) + if (dtype == "INT32" && !is_enum) vals <- if (use_int64) bit64::as.integer64(vals) else as.integer(vals) + return(tiledb_query_condition_create(attr, vals, tdbop)) + # eqconds <- Map(.neweqcond, vals, attr) + # orcond <- Reduce(.neworcond, eqconds) + } else if (.isComparisonOperator(x[1])) { + op <- as.character(x[1]) + attr <- as.character(x[2]) + ch <- as.character(x[3]) + dtype <- .getType(ch, attr, use_int64) + is_enum <- FALSE # default is no + if (.hasArray) { ind <- match(attr, ta@sil$names) if (!is.finite(ind)) { - .errorFunction("No attribute '", attr, "' present.", call. = FALSE) - return(NULL) + .errorFunction("No attribute '", attr, "' present.", call. = FALSE) + return(NULL) } if (ta@sil$status[ind] != 2) { - .errorFunction("Argument '", attr, "' is not an attribute.", call. = FALSE) - return(NULL) + .errorFunction("Argument '", attr, "' is not an attribute.", call. = FALSE) + return(NULL) } - ind - } - .getType <- function(x, tp, use_int64=FALSE) { - if (.hasArray) { - ind <- .getInd(tp, ta) - dtype <- ta@sil$types[ind] - return(dtype) - } - if (isTRUE(.isInteger(x))) { if (use_int64) "INT64" else "INT32" } - else if (isTRUE(.isDouble(x))) "FLOAT64" - else "ASCII" - } - .mapOpToCharacter <- function(x) switch(x, - `>` = "GT", - `>=` = "GE", - `<` = "LT", - `<=` = "LE", - `==` = "EQ", - `!=` = "NE") - .mapBoolToCharacter <- function(x) switch(x, - `&&` = "AND", - `&` = "AND", - `||` = "OR", - `|` = "OR", - `!` = "NOT") - .neweqcond <- function(val, attr) { - if (debug) cat(" ", attr, "EQ", val, "\n") - tiledb_query_condition_init(attr = attr, value = val, dtype = "ASCII", op = "EQ") - } - .neworcond <- function(op1, op2) tiledb_query_condition_combine(op1, op2, "OR") - .makeExpr <- function(x, debug=FALSE) { - if (is.symbol(x)) { - stop("Unexpected symbol in expression: ", format(x)) - } else if (x[[1]] == '(') { - if (debug) cat("-- [(", as.character(x[2]), ")]\n", sep="") - .makeExpr(x[[2]]) - } else if (.isBooleanOperator(x[1])) { - if (debug) cat("-- [", as.character(x[2]), "]", - " ", as.character(x[1]), - " [", as.character(x[3]), "]\n", sep="") - .makeExpr(x[[2]], debug=debug) - .makeExpr(x[[3]], debug=debug) - tiledb_query_condition_combine(.makeExpr(x[[2]]), - .makeExpr(x[[3]]), - .mapBoolToCharacter(as.character(x[1]))) - } else if (.isInOperator(x[1])) { - if (debug) cat("in: [", as.character(x[2]), "]", - " ", as.character(x[1]), - " [", as.character(x[3]), "]\n", sep="") - attr <- as.character(x[2]) - op <- tolower(as.character(x[1])) - tdbop <- if (op == "%in%") "IN" else "NOT_IN" - ind <- .getInd(attr, ta) - dtype <- ta@sil$types[ind] - is_enum <- ta@sil$enum[ind] - vals <- eval(parse(text=as.character(x[3]))) - if (dtype == "INT32" && !is_enum) vals <- if (use_int64) bit64::as.integer64(vals) else as.integer(vals) - return(tiledb_query_condition_create(attr, vals, tdbop)) - #eqconds <- Map(.neweqcond, vals, attr) - #orcond <- Reduce(.neworcond, eqconds) - } else if (.isComparisonOperator(x[1])) { - op <- as.character(x[1]) - attr <- as.character(x[2]) - ch <- as.character(x[3]) - dtype <- .getType(ch, attr, use_int64) - is_enum <- FALSE # default is no - if (.hasArray) { - ind <- match(attr, ta@sil$names) - if (!is.finite(ind)) { - .errorFunction("No attribute '", attr, "' present.", call. = FALSE) - return(NULL) - } - if (ta@sil$status[ind] != 2) { - .errorFunction("Argument '", attr, "' is not an attribute.", call. = FALSE) - return(NULL) - } - dtype <- ta@sil$types[ind] - is_enum <- ta@sil$enum[ind] - } - if (debug) cat(" [", attr,"] ", - op, " (aka ", .mapOpToCharacter(op), ")", - " [",ch, "] ", dtype, "\n", sep="") + dtype <- ta@sil$types[ind] + is_enum <- ta@sil$enum[ind] + } + if (debug) { + cat(" [", attr, "] ", + op, " (aka ", .mapOpToCharacter(op), ")", + " [", ch, "] ", dtype, "\n", + sep = "" + ) + } - ## take care of factor (aka "enum" case) and set the data type to ASCII - if (dtype %in% c("INT8", "INT16", "INT32", "INT64", "UINT8", "UINT16", "UINT32", "UINT64") && is_enum) { - if (debug) cat(" [factor column] ", ch, " ", attr, " ", dtype, " --> ASCII", " ", is_enum, "\n") - dtype <- "ASCII" - } + ## take care of factor (aka "enum" case) and set the data type to ASCII + if (dtype %in% c("INT8", "INT16", "INT32", "INT64", "UINT8", "UINT16", "UINT32", "UINT64") && is_enum) { + if (debug) cat(" [factor column] ", ch, " ", attr, " ", dtype, " --> ASCII", " ", is_enum, "\n") + dtype <- "ASCII" + } - ## general case of extracting appropriate value give type info - tiledb_query_condition_init(attr = attr, - value = switch(dtype, - ASCII = ch, - UTF8 = ch, - BOOL = as.logical(ch), - DATETIME_MS = as.POSIXct(ch), - DATETIME_DAY = as.Date(ch), - as.numeric(ch)), - dtype = dtype, - op = .mapOpToCharacter(op)) - } else { - stop("Unexpected token in expression: ", format(x)) - } + ## general case of extracting appropriate value give type info + tiledb_query_condition_init( + attr = attr, + value = switch(dtype, + ASCII = ch, + UTF8 = ch, + BOOL = as.logical(ch), + DATETIME_MS = as.POSIXct(ch), + DATETIME_DAY = as.Date(ch), + as.numeric(ch) + ), + dtype = dtype, + op = .mapOpToCharacter(op) + ) + } else { + stop("Unexpected token in expression: ", format(x)) } + } - e <- substitute(expr) - .makeExpr(e, debug) + e <- substitute(expr) + .makeExpr(e, debug) } #' Enable use of enumeration in query condition @@ -275,11 +313,13 @@ parse_query_condition <- function(expr, ta=NULL, debug=FALSE, strict=TRUE, use_i #' @return Nothing is retuned, the function is invoked for the side effect #' @export tiledb_query_condition_set_use_enumeration <- function(qc, use_enum, ctx = tiledb_get_context()) { - stopifnot("Argument 'qc' must be a query condition object" = is(qc, "tiledb_query_condition"), - "Argument 'use_enum' must be logical" = is.logical(use_enum), - "The 'ctx' argument must be a context object" = is(ctx, "tiledb_ctx"), - "This function needs TileDB 2.17.0 or later" = tiledb_version(TRUE) >= "2.17.0") - libtiledb_query_condition_set_use_enumeration(ctx@ptr, qc@ptr, use_enum) + stopifnot( + "Argument 'qc' must be a query condition object" = is(qc, "tiledb_query_condition"), + "Argument 'use_enum' must be logical" = is.logical(use_enum), + "The 'ctx' argument must be a context object" = is(ctx, "tiledb_ctx"), + "This function needs TileDB 2.17.0 or later" = tiledb_version(TRUE) >= "2.17.0" + ) + libtiledb_query_condition_set_use_enumeration(ctx@ptr, qc@ptr, use_enum) } #' Create a query condition for vector 'IN' and 'NOT_IN' operations @@ -295,13 +335,15 @@ tiledb_query_condition_set_use_enumeration <- function(qc, use_enum, ctx = tiled #' @return A query condition object is returned #' @export tiledb_query_condition_create <- function(name, values, op = "IN", ctx = tiledb_get_context()) { - stopifnot("Argument 'name' must be character" = is.character(name), - "Argument 'values' must be int, double, int64 ir char" = - (is.numeric(values) || bit64::is.integer64(values) || is.character(values)), - "Argument 'op' must be one of 'IN' or 'NOT_IN'" = op %in% c("IN", "NOT_IN"), - "The 'ctx' argument must be a context object" = is(ctx, "tiledb_ctx"), - "This function needs TileDB 2.17.0 or later" = tiledb_version(TRUE) >= "2.17.0") - ptr <- libtiledb_query_condition_create(ctx@ptr, name, values, op) - qc <- new("tiledb_query_condition", ptr = ptr, init = TRUE) - invisible(qc) + stopifnot( + "Argument 'name' must be character" = is.character(name), + "Argument 'values' must be int, double, int64 ir char" = + (is.numeric(values) || bit64::is.integer64(values) || is.character(values)), + "Argument 'op' must be one of 'IN' or 'NOT_IN'" = op %in% c("IN", "NOT_IN"), + "The 'ctx' argument must be a context object" = is(ctx, "tiledb_ctx"), + "This function needs TileDB 2.17.0 or later" = tiledb_version(TRUE) >= "2.17.0" + ) + ptr <- libtiledb_query_condition_create(ctx@ptr, name, values, op) + qc <- new("tiledb_query_condition", ptr = ptr, init = TRUE) + invisible(qc) } diff --git a/R/SparseMatrix.R b/R/SparseMatrix.R index 20f73f373a..ae10ff6b70 100644 --- a/R/SparseMatrix.R +++ b/R/SparseMatrix.R @@ -40,109 +40,121 @@ ##' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} ##' \dontrun{ ##' if (requireNamespace("Matrix", quietly=TRUE)) { -##' library(Matrix) -##' set.seed(123) # just to fix it -##' mat <- matrix(0, nrow=20, ncol=10) -##' mat[sample(seq_len(200), 20)] <- seq(1, 20) -##' spmat <- as(mat, "dgTMatrix") # sparse matrix in dgTMatrix format -##' uri <- "sparse_matrix" -##' fromSparseMatrix(spmat, uri) # now written -##' chk <- toSparseMatrix(uri) # and re-read -##' print(chk) -##' all.equal(spmat, chk) +##' library(Matrix) +##' set.seed(123) # just to fix it +##' mat <- matrix(0, nrow=20, ncol=10) +##' mat[sample(seq_len(200), 20)] <- seq(1, 20) +##' spmat <- as(mat, "dgTMatrix") # sparse matrix in dgTMatrix format +##' uri <- "sparse_matrix" +##' fromSparseMatrix(spmat, uri) # now written +##' chk <- toSparseMatrix(uri) # and re-read +##' print(chk) +##' all.equal(spmat, chk) ##' } ##' } ##' @importFrom methods as ##' @export -fromSparseMatrix <- function(obj, - uri, - cell_order = "ROW_MAJOR", - tile_order = "ROW_MAJOR", - filter="ZSTD", - capacity = 10000L) { - - stopifnot(`Argument 'obj' must be Matrix object` = inherits(obj, "Matrix"), - `Argument 'obj' must be sparse` = is(obj, "sparseMatrix"), - `Argument 'uri' must be character` = is.character(uri)) - - dimnm <- dimnames(obj) - classIn <- "dgTMatrix" - if (class(obj)[1] != classIn) { - classIn <- class(obj)[1] - obj <- as(obj, "TsparseMatrix") - } - - dimi <- tiledb_dim(name="i", type = "FLOAT64", # wider range - tile = as.numeric(obj@Dim[1]), - domain = c(0, obj@Dim[1]-1L)) - dimj <- tiledb_dim(name="j", type = "FLOAT64", # wider range - tile = as.numeric(obj@Dim[2]), - domain = c(0, obj@Dim[2]-1L)) - dom <- tiledb_domain(dims = c(dimi, dimj)) - - cl <- class(obj@x)[1] - if (cl == "integer") - tp <- "INT32" - else if (cl == "numeric") - tp <- "FLOAT64" - else - stop("Currently unsupported type: ", cl) - - filterlist <- tiledb_filter_list(sapply(filter, tiledb_filter)) - - attx <- tiledb_attr(name="x", type = tp, ncells = 1, filter_list = filterlist) - schema <- tiledb_array_schema(dom, - attrs = attx, - cell_order = cell_order, - tile_order = tile_order, - sparse = TRUE, - capacity=capacity) - tiledb_array_create(uri, schema) - arr <- tiledb_array(uri) - arr[] <- data.frame(i = obj@i, j = obj@j, x = obj@x) - - if (!is.null(dimnm[[1]])) fromDataFrame(data.frame(names=dimnm[[1]]), paste0(uri, "_rows")) - if (!is.null(dimnm[[2]])) fromDataFrame(data.frame(names=dimnm[[2]]), paste0(uri, "_cols")) - - invisible(NULL) +fromSparseMatrix <- function( + obj, + uri, + cell_order = "ROW_MAJOR", + tile_order = "ROW_MAJOR", + filter = "ZSTD", + capacity = 10000L +) { + stopifnot( + `Argument 'obj' must be Matrix object` = inherits(obj, "Matrix"), + `Argument 'obj' must be sparse` = is(obj, "sparseMatrix"), + `Argument 'uri' must be character` = is.character(uri) + ) + + dimnm <- dimnames(obj) + classIn <- "dgTMatrix" + if (class(obj)[1] != classIn) { + classIn <- class(obj)[1] + obj <- as(obj, "TsparseMatrix") + } + + dimi <- tiledb_dim( + name = "i", type = "FLOAT64", # wider range + tile = as.numeric(obj@Dim[1]), + domain = c(0, obj@Dim[1] - 1L) + ) + dimj <- tiledb_dim( + name = "j", type = "FLOAT64", # wider range + tile = as.numeric(obj@Dim[2]), + domain = c(0, obj@Dim[2] - 1L) + ) + dom <- tiledb_domain(dims = c(dimi, dimj)) + + cl <- class(obj@x)[1] + if (cl == "integer") { + tp <- "INT32" + } else if (cl == "numeric") { + tp <- "FLOAT64" + } else { + stop("Currently unsupported type: ", cl) + } + + filterlist <- tiledb_filter_list(sapply(filter, tiledb_filter)) + + attx <- tiledb_attr(name = "x", type = tp, ncells = 1, filter_list = filterlist) + schema <- tiledb_array_schema(dom, + attrs = attx, + cell_order = cell_order, + tile_order = tile_order, + sparse = TRUE, + capacity = capacity + ) + tiledb_array_create(uri, schema) + arr <- tiledb_array(uri) + arr[] <- data.frame(i = obj@i, j = obj@j, x = obj@x) + + if (!is.null(dimnm[[1]])) fromDataFrame(data.frame(names = dimnm[[1]]), paste0(uri, "_rows")) + if (!is.null(dimnm[[2]])) fromDataFrame(data.frame(names = dimnm[[2]]), paste0(uri, "_cols")) + + invisible(NULL) } ##' @rdname fromSparseMatrix ##' @export toSparseMatrix <- function(uri) { - stopifnot(`Argument 'uri' must be character` = is.character(uri)) - - arr <- tiledb_array(uri, return_as="data.frame", query_layout="UNORDERED") - obj <- arr[] - - dimnm <- list(NULL, NULL) # by default no dimnames - rowarr <- paste0(uri, "_rows") - vfs <- tiledb_get_vfs() - if (dir.exists(rowarr)) { # && tiledb_vfs_is_dir(rowarr, vfs)) { - arr <- tiledb_array(rowarr, extended=FALSE, return_as="data.frame")[] - dimnm[[1]] <- arr[,1] - } - colarr <- paste0(uri, "_cols") - if (dir.exists(colarr)) { # && tiledb_vfs_is_dir(colarr, vfs)) { - arr <- tiledb_array(colarr, extended=FALSE, return_as="data.frame")[] - dimnm[[2]] <- arr[,1] - } - - dims <- dimensions(domain(schema(uri))) - d1 <- domain(dims[[1]]) - d2 <- domain(dims[[2]]) - stopifnot(`No column i in data`=!is.na(match("i", colnames(obj))), - `No column j in data`=!is.na(match("j", colnames(obj))), - `No column x in data`=!is.na(match("x", colnames(obj))), - `Matrix package needed`=requireNamespace("Matrix", quietly=TRUE)) - - sp <- Matrix::sparseMatrix(i = obj$i + 1, - j = obj$j + 1, - x = obj$x, - dims = c(d1[2] + 1, d2[2] + 1), - dimnames = dimnm, - repr = "T") - - sp - + stopifnot(`Argument 'uri' must be character` = is.character(uri)) + + arr <- tiledb_array(uri, return_as = "data.frame", query_layout = "UNORDERED") + obj <- arr[] + + dimnm <- list(NULL, NULL) # by default no dimnames + rowarr <- paste0(uri, "_rows") + vfs <- tiledb_get_vfs() + if (dir.exists(rowarr)) { # && tiledb_vfs_is_dir(rowarr, vfs)) { + arr <- tiledb_array(rowarr, extended = FALSE, return_as = "data.frame")[] + dimnm[[1]] <- arr[, 1] + } + colarr <- paste0(uri, "_cols") + if (dir.exists(colarr)) { # && tiledb_vfs_is_dir(colarr, vfs)) { + arr <- tiledb_array(colarr, extended = FALSE, return_as = "data.frame")[] + dimnm[[2]] <- arr[, 1] + } + + dims <- dimensions(domain(schema(uri))) + d1 <- domain(dims[[1]]) + d2 <- domain(dims[[2]]) + stopifnot( + `No column i in data` = !is.na(match("i", colnames(obj))), + `No column j in data` = !is.na(match("j", colnames(obj))), + `No column x in data` = !is.na(match("x", colnames(obj))), + `Matrix package needed` = requireNamespace("Matrix", quietly = TRUE) + ) + + sp <- Matrix::sparseMatrix( + i = obj$i + 1, + j = obj$j + 1, + x = obj$x, + dims = c(d1[2] + 1, d2[2] + 1), + dimnames = dimnm, + repr = "T" + ) + + sp } diff --git a/R/Stats.R b/R/Stats.R index e1efdb9527..0ec58b0935 100644 --- a/R/Stats.R +++ b/R/Stats.R @@ -49,7 +49,9 @@ tiledb_stats_reset <- function() { #' @param path Character variable with path to stats file; #' if the empty string is passed then the result is displayed on stdout. #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' pth <- tempfile() #' tiledb_stats_dump(pth) #' cat(readLines(pth)[1:10], sep = "\n") @@ -72,12 +74,14 @@ tiledb_stats_print <- function() { #' #' This function requires TileDB Embedded 2.0.3 or later. #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' txt <- tiledb_stats_raw_dump() #' cat(txt, "\n") #' @export tiledb_stats_raw_dump <- function() { - libtiledb_stats_raw_dump() + libtiledb_stats_raw_dump() } #' Print internal TileDB statistics as JSON @@ -86,7 +90,7 @@ tiledb_stats_raw_dump <- function() { #' It required TileDB Embedded 2.0.3 or later. #' @export tiledb_stats_raw_print <- function() { - cat(libtiledb_stats_raw_dump(), "\n") + cat(libtiledb_stats_raw_dump(), "\n") } #' Gets internal TileDB statistics as JSON string @@ -96,6 +100,6 @@ tiledb_stats_raw_print <- function() { #' It required TileDB Embedded 2.0.3 or later. #' @export tiledb_stats_raw_get <- function() { - .Deprecated(msg="Use 'tiledb_stats_raw_dump' instead of 'tiledb_stats_raw_get'.") - libtiledb_stats_raw_get() - } + .Deprecated(msg = "Use 'tiledb_stats_raw_dump' instead of 'tiledb_stats_raw_get'.") + libtiledb_stats_raw_get() +} diff --git a/R/Subarray.R b/R/Subarray.R index 8922a9998a..213ddefa5c 100644 --- a/R/Subarray.R +++ b/R/Subarray.R @@ -25,12 +25,15 @@ #' @slot ptr External pointer to the underlying implementation #' @exportClass tiledb_subarray setClass("tiledb_subarray", - slots = list(ptr = "externalptr")) + slots = list(ptr = "externalptr") +) tiledb_subarray.from_ptr <- function(ptr) { - stopifnot("ptr must be a non-NULL externalptr to a tiledb_subarray" = - !missing(ptr) && is(ptr, "externalptr") && !is.null(ptr)) - return(new("tiledb_subarray", ptr = ptr)) + stopifnot( + "ptr must be a non-NULL externalptr to a tiledb_subarray" = + !missing(ptr) && is(ptr, "externalptr") && !is.null(ptr) + ) + return(new("tiledb_subarray", ptr = ptr)) } #' Constructs a `tiledb_subarray` object from a TileDB Query @@ -39,9 +42,9 @@ tiledb_subarray.from_ptr <- function(ptr) { #' @return tiledb_subarray object #' @export tiledb_subarray <- function(query) { - stopifnot("Argument 'query' must be a tiledb_query object" = is(query, "tiledb_query")) - ptr <- libtiledb_subarray(query@ptr) - return(new("tiledb_subarray", ptr = ptr)) + stopifnot("Argument 'query' must be a tiledb_query object" = is(query, "tiledb_query")) + ptr <- libtiledb_subarray(query@ptr) + return(new("tiledb_subarray", ptr = ptr)) } #' Apply a Subarray to a Query @@ -51,8 +54,10 @@ tiledb_subarray <- function(query) { #' @return tiledb_query object #' @export tiledb_subarray_to_query <- function(query, subarray) { - stopifnot("Argument 'query' must be a tiledb_query object" = is(query, "tiledb_query"), - "Argument 'subarray' must be a tiledb_subarray" = is(subarray, "tiledb_subarray")) - query@ptr <- libtiledb_query_set_subarray_object(query@ptr, subarray@ptr) - query + stopifnot( + "Argument 'query' must be a tiledb_query object" = is(query, "tiledb_query"), + "Argument 'subarray' must be a tiledb_subarray" = is(subarray, "tiledb_subarray") + ) + query@ptr <- libtiledb_query_set_subarray_object(query@ptr, subarray@ptr) + query } diff --git a/R/TileDB-Package.R b/R/TileDB-Package.R index 8013b197ff..5560a4d42b 100644 --- a/R/TileDB-Package.R +++ b/R/TileDB-Package.R @@ -24,7 +24,7 @@ #' #' The efficient multi-dimensional array management system #' 'TileDB' introduces a novel on-disk format that can effectively store -#" dense and sparse array data with support for fast updates and +# " dense and sparse array data with support for fast updates and #' reads. It features excellent compression, an efficient parallel I/O #' system which also scales well, and bindings to multiple languages. diff --git a/R/TileDBArray.R b/R/TileDBArray.R index a089c3fe5e..199bf5e7dd 100644 --- a/R/TileDBArray.R +++ b/R/TileDBArray.R @@ -30,11 +30,12 @@ #' @slot ctx A TileDB context object #' @slot uri A character despription with the array URI #' @slot is.sparse A logical value whether the array is sparse or not -#' @slot attrs A character vector to select particular column \sQuote{attributes}; -#' default is an empty character vector implying \sQuote{all} columns, the special -#' value \code{NA_character_} has the opposite effect and selects \sQuote{none}. -#' @slot extended A logical value, defaults to \code{TRUE}, indicating whether index -#' columns are returned as well. +#' @slot attrs A character vector to select particular column +#' \sQuote{attributes}; default is an empty character vector implying +#' \sQuote{all} columns, the special value \code{NA_character_} has the opposite +#' effect and selects \sQuote{none}. +#' @slot extended A logical value, defaults to \code{TRUE}, indicating whether +#' index columns are returned as well. #' @slot selected_ranges An optional list with matrices where each matrix i #' describes the (min,max) pair of ranges for dimension i #' @slot selected_points An optional list with vectors where each vector i @@ -43,48 +44,58 @@ #' @slot datetimes_as_int64 A logical value #' @slot encryption_key A character value #' @slot query_condition A Query Condition object -#' @slot timestamp_start A POSIXct datetime variable for the inclusive interval start -#' @slot timestamp_end A POSIXct datetime variable for the inclusive interval start -#' @slot return_as A character value with the desired \code{tiledb_array} conversion, -#' permitted values are \sQuote{asis} (default, returning a list of columns), -#' \sQuote{array}, \sQuote{matrix},\sQuote{data.frame}, \sQuote{data.table} -#' \sQuote{tibble}, \sQuote{arrow_table} or \sQuote{arrow} (where the last two are synomyms); -#' note that \sQuote{data.table}, \sQuote{tibble} and \sQuote{arrow} require the respective -#' packages to installed. -#' @slot query_statistics A logical value, defaults to \sQuote{FALSE}; if \sQuote{TRUE} the -#' query statistics are returned (as a JSON string) via the attribute -#' \sQuote{query_statistics} of the return object. -#' @slot sil An optional and internal list object with schema information, used for -#' parsing queries. -#' @slot dumpbuffers An optional character variable with a directory name (relative to -#' \code{/dev/shm}) for writing out results buffers (for internal use / testing) -#' @slot buffers An optional list with full pathnames of shared memory buffers to read data from -#' @slot strings_as_factors An optional logical to convert character columns to factor type +#' @slot timestamp_start A POSIXct datetime variable for the inclusive +#' interval start +#' @slot timestamp_end A POSIXct datetime variable for the inclusive +#' interval start +#' @slot return_as A character value with the desired \code{tiledb_array} +#' conversion, permitted values are \sQuote{asis} (default, returning a list +#' of columns), \sQuote{array}, \sQuote{matrix},\sQuote{data.frame}, +#' \sQuote{data.table} \sQuote{tibble}, \sQuote{arrow_table} or \sQuote{arrow} +#' (where the last two are synomyms); note that \sQuote{data.table}, +#' \sQuote{tibble} and \sQuote{arrow} require the respective packages +#' to be installed. +#' @slot query_statistics A logical value, defaults to \sQuote{FALSE}; if +#' \sQuote{TRUE} the query statistics are returned (as a JSON string) via the +#' attribute \sQuote{query_statistics} of the return object. +#' @slot sil An optional and internal list object with schema information, used +#' for parsing queries. +#' @slot dumpbuffers An optional character variable with a directory name +#' (relative to \code{/dev/shm}) for writing out results buffers (for internal +#' use / testing) +#' @slot buffers An optional list with full pathnames of shared memory buffers +#' to read data from +#' @slot strings_as_factors An optional logical to convert character columns to +#' factor type #' @slot keep_open An optional logical to not close after read or write #' @slot ptr External pointer to the underlying implementation #' @exportClass tiledb_array -setClass("tiledb_array", - slots = list(ctx = "tiledb_ctx", - uri = "character", - is.sparse = "logical", - attrs = "character", - extended = "logical", - selected_ranges = "list", - selected_points = "list", - query_layout = "character", - datetimes_as_int64 = "logical", - encryption_key = "character", - query_condition = "tiledb_query_condition", - timestamp_start = "POSIXct", - timestamp_end = "POSIXct", - return_as = "character", - query_statistics = "logical", - strings_as_factors = "logical", - keep_open = "logical", - sil = "list", - dumpbuffers = "character", - buffers = "list", - ptr = "externalptr")) +setClass( + "tiledb_array", + slots = list( + ctx = "tiledb_ctx", + uri = "character", + is.sparse = "logical", + attrs = "character", + extended = "logical", + selected_ranges = "list", + selected_points = "list", + query_layout = "character", + datetimes_as_int64 = "logical", + encryption_key = "character", + query_condition = "tiledb_query_condition", + timestamp_start = "POSIXct", + timestamp_end = "POSIXct", + return_as = "character", + query_statistics = "logical", + strings_as_factors = "logical", + keep_open = "logical", + sil = "list", + dumpbuffers = "character", + buffers = "list", + ptr = "externalptr" + ) +) #' Constructs a tiledb_array object backed by a persisted tiledb array uri #' @@ -92,7 +103,8 @@ setClass("tiledb_array", #' #' @param uri uri path to the tiledb dense array #' @param query_type optionally loads the array in "READ" or "WRITE" only modes. -#' @param is.sparse optional logical switch, defaults to "NA" letting array determine it +#' @param is.sparse optional logical switch, defaults to "NA" +#' letting array determine it #' @param attrs optional character vector to select attributes, default is #' empty implying all are selected, the special value \code{NA_character_} #' has the opposite effect and implies no attributes are returned. @@ -104,67 +116,80 @@ setClass("tiledb_array", #' describes the points selected in dimension i #' @param query_layout optional A value for the TileDB query layout, defaults to #' an empty character variable indicating no special layout is set -#' @param datetimes_as_int64 optional A logical value selecting date and datetime value -#' representation as \sQuote{raw} \code{integer64} and not as \code{Date}, -#' \code{POSIXct} or \code{nanotime} objects. -#' @param encryption_key optional A character value with an AES-256 encryption key -#' in case the array was written with encryption. -#' @param query_condition optional \code{tiledb_query_condition} object, by default uninitialized -#' without a condition; this functionality requires TileDB 2.3.0 or later -#' @param timestamp_start optional A POSIXct Datetime value determining the inclusive time point -#' at which the array is to be openened. No fragments written earlier will be considered. -#' @param timestamp_end optional A POSIXct Datetime value determining the inclusive time point -#' until which the array is to be openened. No fragments written earlier later be considered. -#' @param return_as optional A character value with the desired \code{tiledb_array} conversion, -#' permitted values are \sQuote{asis} (default, returning a list of columns), \sQuote{array}, -#' \sQuote{matrix},\sQuote{data.frame}, \sQuote{data.table}, \sQuote{tibble}, \sQuote{arrow_table}, -#' or \sQuote{arrow} (as an alias for \sQuote{arrow_table}; here \sQuote{data.table}, -#' \sQuote{tibble} and \sQuote{arrow} require the respective packages to be installed. +#' @param datetimes_as_int64 optional A logical value selecting date and +#' datetime value representation as \sQuote{raw} \code{integer64} and not as +#' \code{Date}, \code{POSIXct} or \code{nanotime} objects. +#' @param encryption_key optional A character value with an AES-256 encryption +#' key in case the array was written with encryption. +#' @param query_condition optional \code{tiledb_query_condition} object, by +#' default uninitialized without a condition; this functionality requires +#' TileDB 2.3.0 or later +#' @param timestamp_start optional A POSIXct Datetime value determining the +#' inclusive time point at which the array is to be openened. No fragments +#' written earlier will be considered. +#' @param timestamp_end optional A POSIXct Datetime value determining the +#' inclusive time point until which the array is to be openened. No fragments +#' written earlier later be considered. +#' @param return_as optional A character value with the desired +#' \code{tiledb_array} conversion, permitted values are \sQuote{asis} (default, +#' returning a list of columns), \sQuote{array}, \sQuote{matrix}, +#' \sQuote{data.frame}, \sQuote{data.table}, \sQuote{tibble}, +#' \sQuote{arrow_table}, or \sQuote{arrow} (as an alias for +#' \sQuote{arrow_table}; here \sQuote{data.table}, \sQuote{tibble} and +#' \sQuote{arrow} require the respective packages to be installed. #' The existing \code{as.*} arguments take precedent over this. -#' @param query_statistics optional A logical value, defaults to \sQuote{FALSE}; if \sQuote{TRUE} the -#' query statistics are returned (as a JSON string) via the attribute -#' \sQuote{query_statistics} of the return object. -#' @param strings_as_factors An optional logical to convert character columns to factor type; defaults -#' to the value of \code{getOption("stringsAsFactors", FALSE)}. +#' @param query_statistics optional A logical value, defaults to \sQuote{FALSE}; +#' if \sQuote{TRUE} the query statistics are returned (as a JSON string) via +#' the attribute \sQuote{query_statistics} of the return object. +#' @param strings_as_factors An optional logical to convert character columns to +#' factor type; defaults to the value of +#' \code{getOption("stringsAsFactors", FALSE)}. #' @param keep_open An optional logical to not close after read or write -#' @param sil optional A list, by default empty to store schema information when query objects are -#' parsed. -#' @param dumpbuffers An optional character variable with a directory name (relative to -#' \code{/dev/shm}) for writing out results buffers (for internal use / testing) -#' @param buffers An optional list with full pathnames of shared memory buffers to read data from +#' @param sil optional A list, by default empty to store schema information +#' when query objects are parsed. +#' @param dumpbuffers An optional character variable with a directory name +#' (relative to \code{/dev/shm}) for writing out results buffers (for +#' internal use / testing) +#' @param buffers An optional list with full pathnames of shared memory buffers +#' to read data from #' @param ctx optional tiledb_ctx -#' @param as.data.frame An optional deprecated alternative to \code{return_as="data.frame"} which has -#' been deprecated and removed, but is still used in one BioConductor package; this argument will be removed +#' @param as.data.frame An optional deprecated alternative to +#' \code{return_as="data.frame"} which has been deprecated and removed, but is +#' still used in one BioConductor package; this argument will be removed #' once the updated package has been released. #' @return tiledb_array object #' @importFrom spdl set_level #' @export -tiledb_array <- function(uri, - query_type = c("READ", "WRITE"), - is.sparse = NA, - attrs = character(), - extended = TRUE, - selected_ranges = list(), - selected_points = list(), - query_layout = character(), - datetimes_as_int64 = FALSE, - encryption_key = character(), - query_condition = new("tiledb_query_condition"), - timestamp_start = as.POSIXct(double(), origin="1970-01-01"), - timestamp_end = as.POSIXct(double(), origin="1970-01-01"), - return_as = get_return_as_preference(), - query_statistics = FALSE, - strings_as_factors = getOption("stringsAsFactors", FALSE), - keep_open = FALSE, - sil = list(), - dumpbuffers = character(), - buffers = list(), - ctx = tiledb_get_context(), - as.data.frame = FALSE) { - stopifnot("Argument 'ctx' must be a tiledb_ctx object" = is(ctx, "tiledb_ctx"), - "Argument 'uri' must be a string scalar" = !missing(uri) && is.scalar(uri, "character"), - "Argument 'matrix' (for 'return_as') cannot be selected for sparse arrays" = - !(isTRUE(is.sparse) && return_as == "matrix")) +tiledb_array <- function( + uri, + query_type = c("READ", "WRITE"), + is.sparse = NA, + attrs = character(), + extended = TRUE, + selected_ranges = list(), + selected_points = list(), + query_layout = character(), + datetimes_as_int64 = FALSE, + encryption_key = character(), + query_condition = new("tiledb_query_condition"), + timestamp_start = as.POSIXct(double(), origin = "1970-01-01"), + timestamp_end = as.POSIXct(double(), origin = "1970-01-01"), + return_as = get_return_as_preference(), + query_statistics = FALSE, + strings_as_factors = getOption("stringsAsFactors", FALSE), + keep_open = FALSE, + sil = list(), + dumpbuffers = character(), + buffers = list(), + ctx = tiledb_get_context(), + as.data.frame = FALSE +) { + stopifnot( + "Argument 'ctx' must be a tiledb_ctx object" = is(ctx, "tiledb_ctx"), + "Argument 'uri' must be a string scalar" = !missing(uri) && is.scalar(uri, "character"), + "Argument 'matrix' (for 'return_as') cannot be selected for sparse arrays" = + !(isTRUE(is.sparse) && return_as == "matrix") + ) query_type <- match.arg(query_type) spdl::debug("[tiledb_array] query is {}", query_type) if (length(encryption_key) > 0) { @@ -175,16 +200,16 @@ tiledb_array <- function(uri, } if (as.data.frame) { - ## accommodating TileDBArray prior to BioConductor 3.20 - .Deprecated(old="as.data.frame", new=r"(return_as="data.frame")") - return_as <- "data.frame" + ## accommodating TileDBArray prior to BioConductor 3.20 + .Deprecated(old = "as.data.frame", new = r"(return_as="data.frame")") + return_as <- "data.frame" } if (length(timestamp_start) > 0) { - libtiledb_array_set_open_timestamp_start(array_xptr, timestamp_start) + libtiledb_array_set_open_timestamp_start(array_xptr, timestamp_start) } if (length(timestamp_end) > 0) { - libtiledb_array_set_open_timestamp_end(array_xptr, timestamp_end) + libtiledb_array_set_open_timestamp_end(array_xptr, timestamp_end) } schema_xptr <- libtiledb_array_get_schema(array_xptr) @@ -200,27 +225,28 @@ tiledb_array <- function(uri, is.sparse <- is_sparse_status if (!keep_open) array_xptr <- libtiledb_array_close(array_xptr) new("tiledb_array", - ctx = ctx, - uri = uri, - is.sparse = is.sparse, - attrs = attrs, - extended = extended, - selected_ranges = selected_ranges, - selected_points = selected_points, - query_layout = query_layout, - datetimes_as_int64 = datetimes_as_int64, - encryption_key = encryption_key, - query_condition = query_condition, - timestamp_start = timestamp_start, - timestamp_end = timestamp_end, - return_as = return_as, - query_statistics = query_statistics, - strings_as_factors = strings_as_factors, - keep_open = keep_open, - sil = sil, - dumpbuffers = dumpbuffers, - buffers = buffers, - ptr = array_xptr) + ctx = ctx, + uri = uri, + is.sparse = is.sparse, + attrs = attrs, + extended = extended, + selected_ranges = selected_ranges, + selected_points = selected_points, + query_layout = query_layout, + datetimes_as_int64 = datetimes_as_int64, + encryption_key = encryption_key, + query_condition = query_condition, + timestamp_start = timestamp_start, + timestamp_end = timestamp_end, + return_as = return_as, + query_statistics = query_statistics, + strings_as_factors = strings_as_factors, + keep_open = keep_open, + sil = sil, + dumpbuffers = dumpbuffers, + buffers = buffers, + ptr = array_xptr + ) } #' Return a schema from a tiledb_array object @@ -234,26 +260,26 @@ setMethod("schema", "tiledb_array", function(object, ...) { enckey <- object@encryption_key if (length(enckey) > 0) { schema_xptr <- libtiledb_array_schema_load_with_key(ctx@ptr, uri, enckey) - } else { + } else { schema_xptr <- libtiledb_array_schema_load(ctx@ptr, uri) } return(tiledb_array_schema.from_ptr(schema_xptr, object@ptr)) }) ## unexported helper function to deal with ... args / enckey in next method -.array_schema_load <- function(ctxptr, uri, enckey=character()) { +.array_schema_load <- function(ctxptr, uri, enckey = character()) { if (length(enckey) > 0) { schema_xptr <- libtiledb_array_schema_load_with_key(ctxptr, uri, enckey) - } else { + } else { schema_xptr <- libtiledb_array_schema_load(ctxptr, uri) } } -.array_open <- function(ctxptr, uri, enckey=character()) { - if (length(enckey) > 0) { - arr_xptr <- libtiledb_array_open_with_key(ctxptr, uri, "READ", enckey) - } else { - arr_xptr <- libtiledb_array_open(ctxptr, uri, "READ") - } +.array_open <- function(ctxptr, uri, enckey = character()) { + if (length(enckey) > 0) { + arr_xptr <- libtiledb_array_open_with_key(ctxptr, uri, "READ", enckey) + } else { + arr_xptr <- libtiledb_array_open(ctxptr, uri, "READ") + } } #' Return a schema from a URI character value @@ -262,10 +288,10 @@ setMethod("schema", "tiledb_array", function(object, ...) { #' @param ... Extra parameters such as \sQuote{enckey}, the encryption key #' @return The scheme for the object setMethod("schema", "character", function(object, ...) { - ctx <- tiledb_get_context() - schema_xptr <- .array_schema_load(ctx@ptr, object, ...) - array_xptr <- .array_open(ctx@ptr, object, ...) - return(tiledb_array_schema.from_ptr(schema_xptr, array_xptr)) + ctx <- tiledb_get_context() + schema_xptr <- .array_schema_load(ctx@ptr, object, ...) + array_xptr <- .array_open(ctx@ptr, object, ...) + return(tiledb_array_schema.from_ptr(schema_xptr, array_xptr)) }) @@ -273,31 +299,44 @@ setMethod("schema", "character", function(object, ...) { #' #' @param object A tiledb array object #' @export -setMethod("show", signature = "tiledb_array", - definition = function (object) { - cat("tiledb_array\n" - ," uri = '", object@uri, "'\n" - ," schema_version = ", tiledb_array_schema_version(schema(object)), "\n" - ," is.sparse = ", if (object@is.sparse) "TRUE" else "FALSE", "\n" - ," attrs = ", if (length(object@attrs) == 0) "(none)" - else paste(object@attrs, collapse=","), "\n" - ," selected_ranges = ", if (length(object@selected_ranges) > 0) sprintf("(%d non-null sets)", sum(sapply(object@selected_ranges, function(x) !is.null(x)))) - else "(none)", "\n" - ," selected_points = ", if (length(object@selected_points) > 0) sprintf("(%d non-null points)", sum(sapply(object@selected_points, function(x) !is.null(x)))) - else "(none)", "\n" - ," extended = ", if (object@extended) "TRUE" else "FALSE" ,"\n" - ," query_layout = ", if (length(object@query_layout) == 0) "(none)" else object@query_layout, "\n" - ," datetimes_as_int64 = ", if (object@datetimes_as_int64) "TRUE" else "FALSE", "\n" - ," encryption_key = ", if (length(object@encryption_key) == 0) "(none)" else "(set)", "\n" - ," query_condition = ", if (isTRUE(object@query_condition@init)) "(set)" else "(none)", "\n" - ," timestamp_start = ", if (length(object@timestamp_start) == 0) "(none)" else format(object@timestamp_start), "\n" - ," timestamp_end = ", if (length(object@timestamp_end) == 0) "(none)" else format(object@timestamp_end), "\n" - ," return_as = '", object@return_as, "'\n" - ," query_statistics = ", if (object@query_statistics) "TRUE" else "FALSE", "\n" - ," strings_as_factors = ", if (object@strings_as_factors) "TRUE" else "FALSE", "\n" - ," keep_open = ", if (object@keep_open) "TRUE" else "FALSE", "\n" - ,sep="") -}) +setMethod( + "show", + signature = "tiledb_array", + definition = function(object) { + cat("tiledb_array\n", + " uri = '", object@uri, "'\n", + " schema_version = ", tiledb_array_schema_version(schema(object)), "\n", + " is.sparse = ", if (object@is.sparse) "TRUE" else "FALSE", "\n", + " attrs = ", if (length(object@attrs) == 0) { + "(none)" + } else { + paste(object@attrs, collapse = ",") + }, "\n", + " selected_ranges = ", if (length(object@selected_ranges) > 0) { + sprintf("(%d non-null sets)", sum(sapply(object@selected_ranges, function(x) !is.null(x)))) + } else { + "(none)" + }, "\n", + " selected_points = ", if (length(object@selected_points) > 0) { + sprintf("(%d non-null points)", sum(sapply(object@selected_points, function(x) !is.null(x)))) + } else { + "(none)" + }, "\n", + " extended = ", if (object@extended) "TRUE" else "FALSE", "\n", + " query_layout = ", if (length(object@query_layout) == 0) "(none)" else object@query_layout, "\n", + " datetimes_as_int64 = ", if (object@datetimes_as_int64) "TRUE" else "FALSE", "\n", + " encryption_key = ", if (length(object@encryption_key) == 0) "(none)" else "(set)", "\n", + " query_condition = ", if (isTRUE(object@query_condition@init)) "(set)" else "(none)", "\n", + " timestamp_start = ", if (length(object@timestamp_start) == 0) "(none)" else format(object@timestamp_start), "\n", + " timestamp_end = ", if (length(object@timestamp_end) == 0) "(none)" else format(object@timestamp_end), "\n", + " return_as = '", object@return_as, "'\n", + " query_statistics = ", if (object@query_statistics) "TRUE" else "FALSE", "\n", + " strings_as_factors = ", if (object@strings_as_factors) "TRUE" else "FALSE", "\n", + " keep_open = ", if (object@keep_open) "TRUE" else "FALSE", "\n", + sep = "" + ) + } +) setValidity("tiledb_array", function(object) { msg <- NULL @@ -395,11 +434,15 @@ setValidity("tiledb_array", function(object) { msg <- c(msg, "The 'ptr' slot does not contain an external pointer.") } - if (!(object@return_as %in% c("asis", "array", "matrix", "data.frame", - "data.table", "tibble", "arrow_table", "arrow"))) { + if (!(object@return_as %in% c( + "asis", "array", "matrix", "data.frame", + "data.table", "tibble", "arrow_table", "arrow" + ))) { valid <- FALSE - msg <- c(msg, paste("The 'return_as' slot must contain one of 'asis', 'array', 'matrix',", - "'data.frame', 'data.table', 'tibble', 'arrow_table' or 'arrow'.")) + msg <- c(msg, paste( + "The 'return_as' slot must contain one of 'asis', 'array', 'matrix',", + "'data.frame', 'data.table', 'tibble', 'arrow_table' or 'arrow'." + )) } if (!is.logical(object@query_statistics)) { @@ -418,7 +461,6 @@ setValidity("tiledb_array", function(object) { } if (valid) TRUE else msg - }) @@ -431,27 +473,29 @@ setValidity("tiledb_array", function(object) { ## ## We also convert the value to integer64 because that is the internal storage format .map2integer64 <- function(val, dtype) { - ## in case it is not a (datetime or (u)int64) type), or already an int64, return unchanged - if ((!grepl("^DATETIME_", dtype) && !grepl("INT64$", dtype)) || inherits(val, "integer64")) - return(val) - - val <- switch(dtype, - "DATETIME_YEAR" = as.numeric(strftime(val, "%Y")) - 1970, - "DATETIME_MONTH" = 12*(as.numeric(strftime(val, "%Y")) - 1970) + as.numeric(strftime(val, "%m")) - 1, - "DATETIME_WEEK" = as.numeric(val)/7, - "DATETIME_DAY" = as.numeric(val), - "DATETIME_HR" = as.numeric(val)/3600, - "DATETIME_MIN" = as.numeric(val)/60, - "DATETIME_SEC" = as.numeric(val), - "DATETIME_MS" = as.numeric(val) * 1e3, - "DATETIME_US" = as.numeric(val) * 1e6, - "DATETIME_NS" = as.numeric(val), - "DATETIME_PS" = as.numeric(val) * 1e3, - "DATETIME_FS" = as.numeric(val) * 1e6, - "DATETIME_AS" = as.numeric(val) * 1e9, - "UINT64" = val, - "INT64" = val) - bit64::as.integer64(val) + ## in case it is not a (datetime or (u)int64) type), or already an int64, return unchanged + if ((!grepl("^DATETIME_", dtype) && !grepl("INT64$", dtype)) || inherits(val, "integer64")) { + return(val) + } + + val <- switch(dtype, + "DATETIME_YEAR" = as.numeric(strftime(val, "%Y")) - 1970, + "DATETIME_MONTH" = 12 * (as.numeric(strftime(val, "%Y")) - 1970) + as.numeric(strftime(val, "%m")) - 1, + "DATETIME_WEEK" = as.numeric(val) / 7, + "DATETIME_DAY" = as.numeric(val), + "DATETIME_HR" = as.numeric(val) / 3600, + "DATETIME_MIN" = as.numeric(val) / 60, + "DATETIME_SEC" = as.numeric(val), + "DATETIME_MS" = as.numeric(val) * 1e3, + "DATETIME_US" = as.numeric(val) * 1e6, + "DATETIME_NS" = as.numeric(val), + "DATETIME_PS" = as.numeric(val) * 1e3, + "DATETIME_FS" = as.numeric(val) * 1e6, + "DATETIME_AS" = as.numeric(val) * 1e9, + "UINT64" = val, + "INT64" = val + ) + bit64::as.integer64(val) } #' Returns a TileDB array, allowing for specific subset ranges. @@ -461,14 +505,15 @@ setValidity("tiledb_array", function(object) { #' This function may still still change; the current implementation should be #' considered as an initial draft. #' @param x tiledb_array object -#' @param i optional row index expression which can be a list in which case minimum and maximum -#' of each list element determine a range; multiple list elements can be used to supply multiple -#' ranges. -#' @param j optional column index expression which can be a list in which case minimum and maximum -#' of each list element determine a range; multiple list elements can be used to supply multiple -#' ranges. +#' @param i optional row index expression which can be a list in which case +#' minimum and maximum of each list element determine a range; multiple list +#' elements can be used to supply multiple ranges. +#' @param j optional column index expression which can be a list in which case +#' minimum and maximum of each list element determine a range; multiple list +#' elements can be used to supply multiple ranges. #' @param ... Extra parameters for method signature, currently unused. -#' @param drop Optional logical switch to drop dimensions, default FALSE, currently unused. +#' @param drop Optional logical switch to drop dimensions, default FALSE, +#' currently unused. #' @return The resulting elements in the selected format #' @import nanotime #' @importFrom nanoarrow as_nanoarrow_array @@ -476,381 +521,399 @@ setValidity("tiledb_array", function(object) { #' @aliases [,tiledb_array-method #' @aliases [,tiledb_array,ANY,tiledb_array-method #' @aliases [,tiledb_array,ANY,ANY,tiledb_array-method -setMethod("[", "tiledb_array", - function(x, i, j, ..., drop = FALSE) { - ## add defaults - if (missing(i)) i <- NULL - if (missing(j)) j <- NULL - k <- NULL - #verbose <- getOption("verbose", FALSE) - - spdl::trace("[tiledb_array] '[' accessor started") - - ## deal with possible n-dim indexing - ndlist <- nd_index_from_syscall(sys.call(), parent.frame()) - if (length(ndlist) >= 0) { - if (length(ndlist) >= 1 && !is.null(ndlist[[1]])) i <- ndlist[[1]] - if (length(ndlist) >= 2 && !is.null(ndlist[[2]])) j <- ndlist[[2]] - if (length(ndlist) >= 3 && !is.null(ndlist[[3]])) k <- ndlist[[3]] - if (length(ndlist) >= 4) message("Indices beyond the third dimension not supported in [i,j,k] form. Use selected_ranges() or selected_points().") - } +setMethod( + "[", + "tiledb_array", + function(x, i, j, ..., drop = FALSE) { + ## add defaults + if (missing(i)) i <- NULL + if (missing(j)) j <- NULL + k <- NULL + # verbose <- getOption("verbose", FALSE) + + spdl::trace("[tiledb_array] '[' accessor started") + + ## deal with possible n-dim indexing + ndlist <- nd_index_from_syscall(sys.call(), parent.frame()) + if (length(ndlist) >= 0) { + if (length(ndlist) >= 1 && !is.null(ndlist[[1]])) i <- ndlist[[1]] + if (length(ndlist) >= 2 && !is.null(ndlist[[2]])) j <- ndlist[[2]] + if (length(ndlist) >= 3 && !is.null(ndlist[[3]])) k <- ndlist[[3]] + if (length(ndlist) >= 4) message("Indices beyond the third dimension not supported in [i,j,k] form. Use selected_ranges() or selected_points().") + } - ctx <- x@ctx - uri <- x@uri - sel <- x@attrs - sch <- tiledb::schema(x) - dom <- tiledb::domain(sch) - layout <- x@query_layout - asint64 <- x@datetimes_as_int64 - enckey <- x@encryption_key - tstamp <- x@timestamp_end - - sparse <- libtiledb_array_schema_sparse(sch@ptr) - - if (x@return_as == "arrow_table") - x@return_as <- "arrow" # normalize - - if (x@return_as %in% c("data.table", "tibble", "arrow")) - if (!requireNamespace(x@return_as, quietly=TRUE)) - stop("The 'return_as' argument value '", x@return_as, "' requires the package '", - x@return_as, "' to be installed.", call. = FALSE) - - use_arrow <- x@return_as == "arrow" - if (use_arrow) { - suppressMessages(do.call(rawToChar(as.raw(c(0x72, 0x65, 0x71, 0x75, 0x69, 0x72, 0x65))), list("nanoarrow"))) - } + ctx <- x@ctx + uri <- x@uri + sel <- x@attrs + sch <- tiledb::schema(x) + dom <- tiledb::domain(sch) + layout <- x@query_layout + asint64 <- x@datetimes_as_int64 + enckey <- x@encryption_key + tstamp <- x@timestamp_end + + sparse <- libtiledb_array_schema_sparse(sch@ptr) + + if (x@return_as == "arrow_table") { + x@return_as <- "arrow" + } # normalize + + if (x@return_as %in% c("data.table", "tibble", "arrow")) { + if (!requireNamespace(x@return_as, quietly = TRUE)) { + stop("The 'return_as' argument value '", x@return_as, "' requires the package '", + x@return_as, "' to be installed.", + call. = FALSE + ) + } + } - dims <- tiledb::dimensions(dom) - ndims <- length(dims) - dimnames <- sapply(dims, function(d) libtiledb_dim_get_name(d@ptr)) - dimtypes <- sapply(dims, function(d) libtiledb_dim_get_datatype(d@ptr)) - dimvarnum <- sapply(dims, function(d) libtiledb_dim_get_cell_val_num(d@ptr)) - dimnullable <- sapply(dims, function(d) FALSE) - dimdictionary <- sapply(dims, function(d) FALSE) - - attrs <- tiledb::attrs(schema(x)) - attrnames <- unname(sapply(attrs, function(a) libtiledb_attribute_get_name(a@ptr))) - attrtypes <- unname(sapply(attrs, function(a) libtiledb_attribute_get_type(a@ptr))) - attrvarnum <- unname(sapply(attrs, function(a) libtiledb_attribute_get_cell_val_num(a@ptr))) - attrnullable <- unname(sapply(attrs, function(a) libtiledb_attribute_get_nullable(a@ptr))) - attrdictionary <- unname(sapply(attrs, function(a) libtiledb_attribute_has_enumeration(ctx@ptr, a@ptr))) - - if (length(sel)==1 && is.na(sel[1])) { # special case of NA selecting no attrs - attrnames <- character() - attrtypes <- character() - attrvarnum <- integer() - attrnullable <- logical() - attrdictionary <- logical() - } + use_arrow <- x@return_as == "arrow" + if (use_arrow) { + suppressMessages(do.call(rawToChar(as.raw(c(0x72, 0x65, 0x71, 0x75, 0x69, 0x72, 0x65))), list("nanoarrow"))) + } - if (length(sel) != 0 && !any(is.na(sel))) { - ind <- match(sel, attrnames) - if (length(ind) == 0) { - stop("Only non-existing columns selected.", call.=FALSE) + dims <- tiledb::dimensions(dom) + ndims <- length(dims) + dimnames <- sapply(dims, function(d) libtiledb_dim_get_name(d@ptr)) + dimtypes <- sapply(dims, function(d) libtiledb_dim_get_datatype(d@ptr)) + dimvarnum <- sapply(dims, function(d) libtiledb_dim_get_cell_val_num(d@ptr)) + dimnullable <- sapply(dims, function(d) FALSE) + dimdictionary <- sapply(dims, function(d) FALSE) + + attrs <- tiledb::attrs(schema(x)) + attrnames <- unname(sapply(attrs, function(a) libtiledb_attribute_get_name(a@ptr))) + attrtypes <- unname(sapply(attrs, function(a) libtiledb_attribute_get_type(a@ptr))) + attrvarnum <- unname(sapply(attrs, function(a) libtiledb_attribute_get_cell_val_num(a@ptr))) + attrnullable <- unname(sapply(attrs, function(a) libtiledb_attribute_get_nullable(a@ptr))) + attrdictionary <- unname(sapply(attrs, function(a) libtiledb_attribute_has_enumeration(ctx@ptr, a@ptr))) + + if (length(sel) == 1 && is.na(sel[1])) { # special case of NA selecting no attrs + attrnames <- character() + attrtypes <- character() + attrvarnum <- integer() + attrnullable <- logical() + attrdictionary <- logical() } - attrnames <- attrnames[ind] - attrtypes <- attrtypes[ind] - attrvarnum <- attrvarnum[ind] - attrnullable <- attrnullable[ind] - attrdictionary <- attrdictionary[ind] - } - if (x@extended) { # if true return dimensions and attributes + if (length(sel) != 0 && !any(is.na(sel))) { + ind <- match(sel, attrnames) + if (length(ind) == 0) { + stop("Only non-existing columns selected.", call. = FALSE) + } + attrnames <- attrnames[ind] + attrtypes <- attrtypes[ind] + attrvarnum <- attrvarnum[ind] + attrnullable <- attrnullable[ind] + attrdictionary <- attrdictionary[ind] + } + + if (x@extended) { # if true return dimensions and attributes allnames <- c(dimnames, attrnames) alltypes <- c(dimtypes, attrtypes) allvarnum <- c(dimvarnum, attrvarnum) allnullable <- c(dimnullable, attrnullable) alldictionary <- c(dimdictionary, attrdictionary) - } else { # otherwise only return attributes + } else { # otherwise only return attributes allnames <- attrnames alltypes <- attrtypes allvarnum <- attrvarnum allnullable <- attrnullable alldictionary <- attrdictionary - } + } - ## A preference can be set in a local per-user configuration file; if no value - ## is set a fallback from the TileDB config object is used. - memory_budget <- get_allocation_size_preference() - spdl::debug("['['] memory budget is {}", memory_budget) + ## A preference can be set in a local per-user configuration file; if no value + ## is set a fallback from the TileDB config object is used. + memory_budget <- get_allocation_size_preference() + spdl::debug("['['] memory budget is {}", memory_budget) - if (length(enckey) > 0) { - arrptr <- libtiledb_array_open_with_key(ctx@ptr, uri, "READ", enckey) - } else { - arrptr <- libtiledb_array_open(ctx@ptr, uri, "READ") - } - if (length(x@timestamp_start) > 0) { + if (length(enckey) > 0) { + arrptr <- libtiledb_array_open_with_key(ctx@ptr, uri, "READ", enckey) + } else { + arrptr <- libtiledb_array_open(ctx@ptr, uri, "READ") + } + if (length(x@timestamp_start) > 0) { spdl::debug("['['] set open_timestamp_start to {}", x@timestamp_start) arrptr <- libtiledb_array_set_open_timestamp_start(arrptr, x@timestamp_start) - } - if (length(x@timestamp_end) > 0) { + } + if (length(x@timestamp_end) > 0) { spdl::debug("['['] set open_timestamp_end to {}", x@timestamp_end) arrptr <- libtiledb_array_set_open_timestamp_end(arrptr, x@timestamp_end) - } - if (length(x@timestamp_start) > 0 || length(x@timestamp_end) > 0) { + } + if (length(x@timestamp_start) > 0 || length(x@timestamp_end) > 0) { arrptr <- libtiledb_array_reopen(arrptr) - } + } - ## dictionaries are schema-level objects to fetch them now where we expect to have some - dictionaries <- vector(mode="list", length=length(allnames)) - names(dictionaries) <- allnames - ordered_dict <- dictionaries - for (ii in seq_along(dictionaries)) { + ## dictionaries are schema-level objects to fetch them now where we expect to have some + dictionaries <- vector(mode = "list", length = length(allnames)) + names(dictionaries) <- allnames + ordered_dict <- dictionaries + for (ii in seq_along(dictionaries)) { if (isTRUE(alldictionary[ii])) { - attr <- attrs[[allnames[ii]]] - tpstr <- tiledb_attribute_get_enumeration_type_ptr(attr, arrptr) - if (tpstr %in% c("ASCII", "UTF8")) { - dictionaries[[ii]] <- tiledb_attribute_get_enumeration_ptr(attr, arrptr) - } else if (tpstr %in% c("FLOAT32", "FLOAT64", "BOOL", - "UINT8", "UINT16", "UINT32", "UINT64", - "INT8", "INT16", "INT32", "INT64")) { - dictionaries[[ii]] <- tiledb_attribute_get_enumeration_vector_ptr(attr, arrptr) - } else { - stop("Unsupported enumeration vector payload of type '%s'", tpstr, call. = FALSE) - } - ordered_dict[[ii]] <- tiledb_attribute_is_ordered_enumeration_ptr(attr, arrptr) - attr(dictionaries[[ii]], "ordered") <- ordered_dict[[ii]] + attr <- attrs[[allnames[ii]]] + tpstr <- tiledb_attribute_get_enumeration_type_ptr(attr, arrptr) + if (tpstr %in% c("ASCII", "UTF8")) { + dictionaries[[ii]] <- tiledb_attribute_get_enumeration_ptr(attr, arrptr) + } else if (tpstr %in% c( + "FLOAT32", "FLOAT64", "BOOL", + "UINT8", "UINT16", "UINT32", "UINT64", + "INT8", "INT16", "INT32", "INT64" + )) { + dictionaries[[ii]] <- tiledb_attribute_get_enumeration_vector_ptr(attr, arrptr) + } else { + stop("Unsupported enumeration vector payload of type '%s'", tpstr, call. = FALSE) + } + ordered_dict[[ii]] <- tiledb_attribute_is_ordered_enumeration_ptr(attr, arrptr) + attr(dictionaries[[ii]], "ordered") <- ordered_dict[[ii]] } - } + } - ## helper function to sweep over names and types of domain - getDomain <- function(nm, tp) { - if (tp %in% c("ASCII", "CHAR", "UTF8")) { - libtiledb_array_get_non_empty_domain_var_from_name(arrptr, nm) - } else { - libtiledb_array_get_non_empty_domain_from_name(arrptr, nm, tp) + ## helper function to sweep over names and types of domain + getDomain <- function(nm, tp) { + if (tp %in% c("ASCII", "CHAR", "UTF8")) { + libtiledb_array_get_non_empty_domain_var_from_name(arrptr, nm) + } else { + libtiledb_array_get_non_empty_domain_from_name(arrptr, nm, tp) + } } - } - nonemptydom <- mapply(getDomain, dimnames, dimtypes, SIMPLIFY=FALSE) + nonemptydom <- mapply(getDomain, dimnames, dimtypes, SIMPLIFY = FALSE) - ## open query - qryptr <- libtiledb_query(ctx@ptr, arrptr, "READ") - qryptr <- libtiledb_query_set_layout(qryptr, if (isTRUE(nzchar(layout))) layout - else { if (sparse) "UNORDERED" else "COL_MAJOR" }) + ## open query + qryptr <- libtiledb_query(ctx@ptr, arrptr, "READ") + qryptr <- libtiledb_query_set_layout(qryptr, if (isTRUE(nzchar(layout))) { + layout + } else { + if (sparse) "UNORDERED" else "COL_MAJOR" + }) - ## ranges seem to interfere with the byte/element adjustment below so set up toggle - rangeunset <- TRUE + ## ranges seem to interfere with the byte/element adjustment below so set up toggle + rangeunset <- TRUE - ## ensure selected_ranges, if submitted, is of correct length - if (length(x@selected_ranges) != 0 && + ## ensure selected_ranges, if submitted, is of correct length + if (length(x@selected_ranges) != 0 && length(x@selected_ranges) != length(dimnames) && is.null(names(x@selected_ranges))) { - stop(paste0("If ranges are selected by index alone (and not named), ", - "one is required for each dimension."), call. = FALSE) - } + stop(paste0( + "If ranges are selected by index alone (and not named), ", + "one is required for each dimension." + ), call. = FALSE) + } - ## ensure selected_points, if submitted, is of correct length - if (length(x@selected_points) != 0 && + ## ensure selected_points, if submitted, is of correct length + if (length(x@selected_points) != 0 && length(x@selected_points) != length(dimnames) && is.null(names(x@selected_points))) { - stop(paste0("If points are selected by index alone (and not named), ", - "one is required for each dimension."), call. = FALSE) - } + stop(paste0( + "If points are selected by index alone (and not named), ", + "one is required for each dimension." + ), call. = FALSE) + } - ## 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)) + ## 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]] + fulllist[[ind[ii]]] <- x@selected_ranges[[ii]] } x@selected_ranges <- fulllist - } + } - ## expand a shorter-but-named selected_points list - if ( (length(x@selected_points) < length(dimnames)) - && (!is.null(names(x@selected_points))) ) { - fulllist <- vector(mode="list", length=length(dimnames)) + ## expand a shorter-but-named selected_points list + if ((length(x@selected_points) < length(dimnames)) && + (!is.null(names(x@selected_points)))) { + fulllist <- vector(mode = "list", length = length(dimnames)) ind <- match(names(x@selected_points), dimnames) if (any(is.na(ind))) stop("Name for selected points does not match dimension names.") for (ii in seq_len(length(ind))) { - fulllist[[ ind[ii] ]] <- x@selected_points[[ii]] + fulllist[[ind[ii]]] <- x@selected_points[[ii]] } x@selected_points <- fulllist - } + } - ## selected_ranges may be in different order than dimnames, so reorder if need be - if ((length(x@selected_ranges) == length(dimnames)) - && (!is.null(names(x@selected_ranges))) - && (!identical(names(x@selected_ranges), dimnames))) { + ## selected_ranges may be in different order than dimnames, so reorder if need be + if ((length(x@selected_ranges) == length(dimnames)) && + (!is.null(names(x@selected_ranges))) && + (!identical(names(x@selected_ranges), dimnames))) { x@selected_ranges <- x@selected_ranges[dimnames] - } + } - ## selected_points may be in different order than dimnames, so reorder if need be - if ((length(x@selected_points) == length(dimnames)) - && (!is.null(names(x@selected_points))) - && (!identical(names(x@selected_points), dimnames))) { + ## selected_points may be in different order than dimnames, so reorder if need be + if ((length(x@selected_points) == length(dimnames)) && + (!is.null(names(x@selected_points))) && + (!identical(names(x@selected_points), dimnames))) { x@selected_points <- x@selected_points[dimnames] - } + } - ## if selected_ranges is still an empty list, make it an explicit one - if (length(x@selected_ranges) == 0) { - x@selected_ranges <- vector(mode="list", length=length(dimnames)) - } + ## if selected_ranges is still an empty list, make it an explicit one + if (length(x@selected_ranges) == 0) { + x@selected_ranges <- vector(mode = "list", length = length(dimnames)) + } - ## if selected_points is still an empty list, make it an explicit one - if (length(x@selected_points) == 0) { - x@selected_points <- vector(mode="list", length=length(dimnames)) - } + ## if selected_points is still an empty list, make it an explicit one + if (length(x@selected_points) == 0) { + x@selected_points <- vector(mode = "list", length = length(dimnames)) + } - if (!is.null(i)) { + if (!is.null(i)) { if (!is.null(x@selected_ranges[[1]])) { - stop("Cannot set both 'i' and first element of 'selected_ranges'.", call. = FALSE) + stop("Cannot set both 'i' and first element of 'selected_ranges'.", call. = FALSE) } x@selected_ranges[[1]] <- i - } + } - if (!is.null(j)) { + if (!is.null(j)) { if (ndims == 1) { - stop("Setting dimension 'j' requires at least two dimensions.", call. = FALSE) + stop("Setting dimension 'j' requires at least two dimensions.", call. = FALSE) } if (!is.null(x@selected_ranges[[2]])) { - stop("Cannot set both 'j' and second element of 'selected_ranges'.", call. = FALSE) + stop("Cannot set both 'j' and second element of 'selected_ranges'.", call. = FALSE) } x@selected_ranges[[2]] <- j - } + } - if (!is.null(k)) { + if (!is.null(k)) { if (ndims <= 2) { - stop("Setting dimension 'k' requires at least three dimensions.", call. = FALSE) + stop("Setting dimension 'k' requires at least three dimensions.", call. = FALSE) } if (!is.null(x@selected_ranges[[3]])) { - stop("Cannot set both 'k' and second element of 'selected_ranges'.", call. = FALSE) + stop("Cannot set both 'k' and second element of 'selected_ranges'.", call. = FALSE) } x@selected_ranges[[3]] <- k - } - ## (i,j,k) are now done and transferred to x@selected_ranges + } + ## (i,j,k) are now done and transferred to x@selected_ranges - ## pointer to subarray needed for iterated setting of points from selected_ranges - ## and selected_points across all possible dimensions - have_made_selection <- FALSE - sbrptr <- libtiledb_subarray(qryptr) + ## pointer to subarray needed for iterated setting of points from selected_ranges + ## and selected_points across all possible dimensions + have_made_selection <- FALSE + sbrptr <- libtiledb_subarray(qryptr) - ## if ranges selected, use those - for (k in seq_len(length(x@selected_ranges))) { + ## if ranges selected, use those + for (k in seq_len(length(x@selected_ranges))) { if (is.null(x@selected_ranges[[k]]) && is.null(x@selected_points[[k]])) { - vec <- .map2integer64(nonemptydom[[k]], dimtypes[k]) - if (vec[1] != 0 || vec[2] != 0) { # corner case of A[] on empty array - sbrptr <- libtiledb_subarray_add_range_with_type(sbrptr, k-1, dimtypes[k], vec[1], vec[2]) - spdl::debug("[tiledb_array] Adding non-zero dim {}:{} on {} with ({},{})", k, i, dimtypes[k], vec[1], vec[2]) - rangeunset <- FALSE - have_made_selection <- TRUE - } - } else if (is.null(nrow(x@selected_ranges[[k]])) && is.null(x@selected_points[[k]])) { - vec <- x@selected_ranges[[k]] - vec <- .map2integer64(vec, dimtypes[k]) - sbrptr <- libtiledb_subarray_add_range_with_type(sbrptr, k-1, dimtypes[k], min(vec), max(vec)) + vec <- .map2integer64(nonemptydom[[k]], dimtypes[k]) + if (vec[1] != 0 || vec[2] != 0) { # corner case of A[] on empty array + sbrptr <- libtiledb_subarray_add_range_with_type(sbrptr, k - 1, dimtypes[k], vec[1], vec[2]) spdl::debug("[tiledb_array] Adding non-zero dim {}:{} on {} with ({},{})", k, i, dimtypes[k], vec[1], vec[2]) rangeunset <- FALSE have_made_selection <- TRUE + } + } else if (is.null(nrow(x@selected_ranges[[k]])) && is.null(x@selected_points[[k]])) { + vec <- x@selected_ranges[[k]] + vec <- .map2integer64(vec, dimtypes[k]) + sbrptr <- libtiledb_subarray_add_range_with_type(sbrptr, k - 1, dimtypes[k], min(vec), max(vec)) + spdl::debug("[tiledb_array] Adding non-zero dim {}:{} on {} with ({},{})", k, i, dimtypes[k], vec[1], vec[2]) + rangeunset <- FALSE + have_made_selection <- TRUE } else if (is.null(x@selected_points[[k]])) { - m <- x@selected_ranges[[k]] - for (i in seq_len(nrow(m))) { - vec <- .map2integer64(c(m[i,1], m[i,2]), dimtypes[k]) - sbrptr <- libtiledb_subarray_add_range_with_type(sbrptr, k-1, dimtypes[k], vec[1], vec[2]) - spdl::debug("[tiledb_array] Adding non-zero dim {}:{} on {} with ({},{})", k, i, dimtypes[k], vec[1], vec[2]) - } - rangeunset <- FALSE - have_made_selection <- TRUE + m <- x@selected_ranges[[k]] + for (i in seq_len(nrow(m))) { + vec <- .map2integer64(c(m[i, 1], m[i, 2]), dimtypes[k]) + sbrptr <- libtiledb_subarray_add_range_with_type(sbrptr, k - 1, dimtypes[k], vec[1], vec[2]) + spdl::debug("[tiledb_array] Adding non-zero dim {}:{} on {} with ({},{})", k, i, dimtypes[k], vec[1], vec[2]) + } + rangeunset <- FALSE + have_made_selection <- TRUE } - } + } - ## if points selected, use those (and fewer special cases as A[i,j,k] not folded into points) - for (k in seq_len(length(x@selected_points))) { + ## if points selected, use those (and fewer special cases as A[i,j,k] not folded into points) + for (k in seq_len(length(x@selected_points))) { if (!is.null(x@selected_points[[k]])) { - m <- x@selected_points[[k]] - for (i in seq_along(m)) { - vec <- .map2integer64(c(m[i], m[i]), dimtypes[k]) - sbrptr <- libtiledb_subarray_add_range_with_type(sbrptr, k-1, dimtypes[k], vec[1], vec[2]) - spdl::debug("[tiledb_array] Adding point on non-zero dim {}:{} on {} with ({},{})", k, i, dimtypes[k], vec[1], vec[2]) - } - rangeunset <- FALSE - have_made_selection <- TRUE + m <- x@selected_points[[k]] + for (i in seq_along(m)) { + vec <- .map2integer64(c(m[i], m[i]), dimtypes[k]) + sbrptr <- libtiledb_subarray_add_range_with_type(sbrptr, k - 1, dimtypes[k], vec[1], vec[2]) + spdl::debug("[tiledb_array] Adding point on non-zero dim {}:{} on {} with ({},{})", k, i, dimtypes[k], vec[1], vec[2]) + } + rangeunset <- FALSE + have_made_selection <- TRUE } - } + } - if (have_made_selection) + if (have_made_selection) { libtiledb_query_set_subarray_object(qryptr, sbrptr) + } - buflist <- vector(mode="list", length=length(allnames)) + buflist <- vector(mode = "list", length = length(allnames)) - if (length(x@buffers) != 0) { # if we were given buffers (as in the case of TileDB Cloud ops) + if (length(x@buffers) != 0) { # if we were given buffers (as in the case of TileDB Cloud ops) nm <- names(x@buffers) - if (!isTRUE(all.equal(nm,allnames))) - stop("Expected ", paste(allnames, collapse=","), " got ", paste(nm, collapse=","), call. = FALSE) + if (!isTRUE(all.equal(nm, allnames))) { + stop("Expected ", paste(allnames, collapse = ","), " got ", paste(nm, collapse = ","), call. = FALSE) + } for (i in seq_along(allnames)) { - n <- allnames[i] - path <- x@buffers[[n]] - if (!file.exists(path)) stop("No buffer for ", n, call. = FALSE) - if (is.na(allvarnum[i])) { - buflist[[i]] <- vlcbuf_from_shmem(path, alltypes[i]) - } else { - buflist[[i]] <- querybuf_from_shmem(path, alltypes[i]) - } + n <- allnames[i] + path <- x@buffers[[n]] + if (!file.exists(path)) stop("No buffer for ", n, call. = FALSE) + if (is.na(allvarnum[i])) { + buflist[[i]] <- vlcbuf_from_shmem(path, alltypes[i]) + } else { + buflist[[i]] <- querybuf_from_shmem(path, alltypes[i]) + } } ## get results (shmem variant) - getResultShmem <- function(buf, name, varnum) { #, resrv, qryptr) { - if (is.na(varnum)) { - vec <- length_from_vlcbuf(buf) - libtiledb_query_get_buffer_var_char(buf, vec[1], vec[2])[,1] - } else { - col <- libtiledb_query_get_buffer_ptr(buf, asint64) - if (!is.null(dictionaries[[name]])) { # if there is a dictionary - dct <- dictionaries[[name]] # access it from utility - ord <- ordered_dict[[name]] - ## the following expands out to a char vector first; we can do better - ## col <- factor(dct[col+1], levels=dct) - ## so we do it "by hand" - col <- col + 1L # adjust for zero-index C/C++ layer - attr(col, "levels") <- dct - attr(col, "class") <- if (ord) c("ordered", "factor") else "factor" - } - col + getResultShmem <- function(buf, name, varnum) { # , resrv, qryptr) { + if (is.na(varnum)) { + vec <- length_from_vlcbuf(buf) + libtiledb_query_get_buffer_var_char(buf, vec[1], vec[2])[, 1] + } else { + col <- libtiledb_query_get_buffer_ptr(buf, asint64) + if (!is.null(dictionaries[[name]])) { # if there is a dictionary + dct <- dictionaries[[name]] # access it from utility + ord <- ordered_dict[[name]] + ## the following expands out to a char vector first; we can do better + ## col <- factor(dct[col+1], levels=dct) + ## so we do it "by hand" + col <- col + 1L # adjust for zero-index C/C++ layer + attr(col, "levels") <- dct + attr(col, "class") <- if (ord) c("ordered", "factor") else "factor" } + col + } } - reslist <- mapply(getResultShmem, buflist, allnames, allvarnum, SIMPLIFY=FALSE) + reslist <- mapply(getResultShmem, buflist, allnames, allvarnum, SIMPLIFY = FALSE) ind <- which(allvarnum != 1 & !is.na(allvarnum)) for (k in ind) { - ncells <- allvarnum[k] - v <- reslist[[k]] - ## we split a vector v into 'list-columns' which element containing - ## ncells value (and we get ncells from the Array schema) - ## see https://stackoverflow.com/a/9547594/143305 for I() - ## and https://stackoverflow.com/a/3321659/143305 for split() - reslist[[k]] <- I(unname(split(v, ceiling(seq_along(v)/ncells)))) + ncells <- allvarnum[k] + v <- reslist[[k]] + ## we split a vector v into 'list-columns' which element containing + ## ncells value (and we get ncells from the Array schema) + ## see https://stackoverflow.com/a/9547594/143305 for I() + ## and https://stackoverflow.com/a/3321659/143305 for split() + reslist[[k]] <- I(unname(split(v, ceiling(seq_along(v) / ncells)))) } res <- data.frame(reslist) colnames(res) <- allnames - - } else { # -- start 'big else' of standard query build + } else { # -- start 'big else' of standard query build ## retrieve est_result_size getEstimatedSize <- function(name, varnum, nullable, qryptr, datatype) { - if (is.na(varnum) && !nullable) { - res <- libtiledb_query_get_est_result_size_var(qryptr, name)[1] - spdl::debug("[getEstimatedSize] column '{}' (is.na(varnum) and !nullable) {}", name, res) - } else if (is.na(varnum) && nullable) { - res <- libtiledb_query_get_est_result_size_var_nullable(qryptr, name)[1] - spdl::debug("[getEstimatedSize] column '{}' (is.na(varnum) and nullable) {}", name, res) - } else if (!is.na(varnum) && !nullable) { - res <- libtiledb_query_get_est_result_size(qryptr, name) - spdl::debug("[getEstimatedSize] column '{}' (!is.na(varnum) and !nullable) {}", name, res) - } else if (!is.na(varnum) && nullable) { - res <- libtiledb_query_get_est_result_size_nullable(qryptr, name)[1] - spdl::debug("[getEstimatedSize] column '{}' (!is.na(varnum) and nullable) {}", name, res) - } - if (rangeunset) { - sz <- tiledb_datatype_string_to_sizeof(datatype) - res <- res / sz - spdl::debug("[getEstimatedSize] column '{}' rangeunset and res scaled to {}", name, res) - } - res + if (is.na(varnum) && !nullable) { + res <- libtiledb_query_get_est_result_size_var(qryptr, name)[1] + spdl::debug("[getEstimatedSize] column '{}' (is.na(varnum) and !nullable) {}", name, res) + } else if (is.na(varnum) && nullable) { + res <- libtiledb_query_get_est_result_size_var_nullable(qryptr, name)[1] + spdl::debug("[getEstimatedSize] column '{}' (is.na(varnum) and nullable) {}", name, res) + } else if (!is.na(varnum) && !nullable) { + res <- libtiledb_query_get_est_result_size(qryptr, name) + spdl::debug("[getEstimatedSize] column '{}' (!is.na(varnum) and !nullable) {}", name, res) + } else if (!is.na(varnum) && nullable) { + res <- libtiledb_query_get_est_result_size_nullable(qryptr, name)[1] + spdl::debug("[getEstimatedSize] column '{}' (!is.na(varnum) and nullable) {}", name, res) + } + if (rangeunset) { + sz <- tiledb_datatype_string_to_sizeof(datatype) + res <- res / sz + spdl::debug("[getEstimatedSize] column '{}' rangeunset and res scaled to {}", name, res) + } + res } ressizes <- mapply(getEstimatedSize, allnames, allvarnum, allnullable, alltypes, - MoreArgs=list(qryptr=qryptr), SIMPLIFY=TRUE) + MoreArgs = list(qryptr = qryptr), SIMPLIFY = TRUE + ) ## ensure > 0 for correct handling of zero-length outputs, ensure respecting memory budget spdl::debug("['['] result of size estimates is {}", paste(ressizes, collapse=",")) idx <- ressizes > 0 @@ -865,309 +928,320 @@ setMethod("[", "tiledb_array", ## allocate and set buffers if (!use_arrow) { - getBuffer <- function(name, type, varnum, nullable, resrv, qryptr, arrptr) { - if (is.na(varnum)) { - if (type %in% c("CHAR", "ASCII", "UTF8")) { - spdl::debug("[getBuffer] '{}' allocating 'char' {} rows given budget of {}", name, resrv, memory_budget) - buf <- libtiledb_query_buffer_var_char_alloc_direct(resrv, memory_budget, nullable) - buf <- libtiledb_query_buffer_var_char_legacy_validity_mode(ctx@ptr, buf) - qryptr <- libtiledb_query_set_buffer_var_char(qryptr, name, buf) - buf - } else { - message("Non-char var.num columns are not currently supported.") - } - } else { - spdl::debug("[getBuffer] '{}' allocating non-char {} rows given budget of {}", name, resrv, memory_budget) - buf <- libtiledb_query_buffer_alloc_ptr(type, resrv, nullable, varnum) - qryptr <- libtiledb_query_set_buffer_ptr(qryptr, name, buf) - buf - } + getBuffer <- function(name, type, varnum, nullable, resrv, qryptr, arrptr) { + if (is.na(varnum)) { + if (type %in% c("CHAR", "ASCII", "UTF8")) { + spdl::debug("[getBuffer] '{}' allocating 'char' {} rows given budget of {}", name, resrv, memory_budget) + buf <- libtiledb_query_buffer_var_char_alloc_direct(resrv, memory_budget, nullable) + buf <- libtiledb_query_buffer_var_char_legacy_validity_mode(ctx@ptr, buf) + qryptr <- libtiledb_query_set_buffer_var_char(qryptr, name, buf) + buf + } else { + message("Non-char var.num columns are not currently supported.") + } + } else { + spdl::debug("[getBuffer] '{}' allocating non-char {} rows given budget of {}", name, resrv, memory_budget) + buf <- libtiledb_query_buffer_alloc_ptr(type, resrv, nullable, varnum) + qryptr <- libtiledb_query_set_buffer_ptr(qryptr, name, buf) + buf } - buflist <- mapply(getBuffer, allnames, alltypes, allvarnum, allnullable, - MoreArgs=list(resrv=resrv, qryptr=qryptr, arrptr=arrptr), - SIMPLIFY=FALSE) - spdl::debug("['['] buffers allocated in list") + } + buflist <- mapply(getBuffer, allnames, alltypes, allvarnum, allnullable, + MoreArgs = list(resrv = resrv, qryptr = qryptr, arrptr = arrptr), + SIMPLIFY = FALSE + ) + spdl::debug("['['] buffers allocated in list") } ## if we have a query condition, apply it if (isTRUE(x@query_condition@init)) { - qryptr <- libtiledb_query_set_condition(qryptr, x@query_condition@ptr) + qryptr <- libtiledb_query_set_condition(qryptr, x@query_condition@ptr) } overallresults <- list() counter <- 1L finished <- FALSE while (!finished) { + if (use_arrow) { + abptr <- libtiledb_allocate_column_buffers(ctx@ptr, qryptr, uri, allnames, memory_budget) + spdl::debug("['['] buffers allocated and set") + } - if (use_arrow) { - abptr <- libtiledb_allocate_column_buffers(ctx@ptr, qryptr, uri, allnames, memory_budget) - spdl::debug("['['] buffers allocated and set") + ## fire off query + spdl::debug( + "['['] query submission: {} array_open {}", counter, + if (libtiledb_array_is_open(arrptr)) "true" else "false" + ) + qryptr <- libtiledb_query_submit(qryptr) + + ## check status + status <- libtiledb_query_status(qryptr) + # if (status != "COMPLETE") warning("Query returned '", status, "'.", call. = FALSE) + if (status != "COMPLETE") spdl::debug("['['] query returned '{}'.", status) + + if (use_arrow) { + ## rl <- libtiledb_to_arrow(abptr, qryptr, dictionaries) + ## at <- .as_arrow_table(rl) + na <- libtiledb_to_arrow(abptr, qryptr, dictionaries) + at <- arrow::as_arrow_table(na) + + ## special case from schema evolution could have added twice so correcting + for (n in colnames(at)) { + v <- at[[n]]$as_vector() + lvls <- levels(v) + if (inherits(v, "factor")) { + vec <- as.integer(v) + vec[vec == -.Machine$integer.max] <- NA_integer_ + if (min(vec, na.rm = TRUE) == 2 && max(vec, na.rm = TRUE) == length(lvls) + 1) { + vec <- vec - 1L + attr(vec, "levels") <- attr(v, "levels") + class(vec) <- class(v) + at[[n]] <- vec + } + } } - ## fire off query - spdl::debug("['['] query submission: {} array_open {}", counter, - if (libtiledb_array_is_open(arrptr)) "true" else "false") - qryptr <- libtiledb_query_submit(qryptr) - - ## check status - status <- libtiledb_query_status(qryptr) - #if (status != "COMPLETE") warning("Query returned '", status, "'.", call. = FALSE) - if (status != "COMPLETE") spdl::debug("['['] query returned '{}'.", status) - - if (use_arrow) { - ## rl <- libtiledb_to_arrow(abptr, qryptr, dictionaries) - ## at <- .as_arrow_table(rl) - na <- libtiledb_to_arrow(abptr, qryptr, dictionaries) - at <- arrow::as_arrow_table(na) - - ## special case from schema evolution could have added twice so correcting - for (n in colnames(at)) { - v <- at[[n]]$as_vector() - lvls <- levels(v) - if (inherits(v, "factor")) { - vec <- as.integer(v) - vec[vec == - .Machine$integer.max] <- NA_integer_ - if (min(vec, na.rm=TRUE) == 2 && max(vec, na.rm=TRUE) == length(lvls) + 1) { - vec <- vec - 1L - attr(vec, "levels") <- attr(v, "levels") - class(vec) <- class(v) - at[[n]] <- vec - } - } - } + ## if dictionaries are to be injected at the R level, this does it + # for (n in names(dictionaries)) { + # if (!is.null(dictionaries[[n]])) { + # at[[n]] <- arrow::DictionaryArray$create(at[[n]]$as_vector(), dictionaries[[n]]) + # } + # } + overallresults[[counter]] <- at + spdl::debug("['['] received arrow table {}", counter) + } - ## if dictionaries are to be injected at the R level, this does it - #for (n in names(dictionaries)) { - # if (!is.null(dictionaries[[n]])) { - # at[[n]] <- arrow::DictionaryArray$create(at[[n]]$as_vector(), dictionaries[[n]]) - # } - #} - overallresults[[counter]] <- at - spdl::debug("['['] received arrow table {}", counter) - } + ## close array + if (status == "COMPLETE") { + if (!x@keep_open) libtiledb_array_close(arrptr) + .pkgenv[["query_status"]] <- status + finished <- TRUE + } - ## close array - if (status == "COMPLETE") { - if (!x@keep_open) libtiledb_array_close(arrptr) - .pkgenv[["query_status"]] <- status - finished <- TRUE + if (!use_arrow) { + ## retrieve actual result size (from fixed size element columns) + getResultSize <- function(name, varnum, qryptr) { + val <- if (is.na(varnum)) { # symbols come up with higher count + libtiledb_query_result_buffer_elements(qryptr, name, 0) + } else { + libtiledb_query_result_buffer_elements(qryptr, name) + } + spdl::debug("[getResultSize] name {} varnum {} has {}", name, varnum, val) + val } - - if (!use_arrow) { - ## retrieve actual result size (from fixed size element columns) - getResultSize <- function(name, varnum, qryptr) { - val <- if (is.na(varnum)) # symbols come up with higher count - libtiledb_query_result_buffer_elements(qryptr, name, 0) - else - libtiledb_query_result_buffer_elements(qryptr, name) - spdl::debug("[getResultSize] name {} varnum {} has {}", name, varnum, val) - val - } - estsz <- mapply(getResultSize, allnames, allvarnum, MoreArgs=list(qryptr=qryptr), SIMPLIFY=TRUE) - spdl::debug("['['] estimated result sizes {}", paste(estsz, collapse=",")) - if (any(!is.na(estsz))) { - resrv <- max(estsz, na.rm=TRUE) - } else { - resrv <- resrv/8 # character case where bytesize of offset vector was used - } - spdl::debug("['['] expected size {}", resrv) - ## Permit one pass to allow zero-row schema read - if (resrv == 0 && counter > 1L) { - finished <- TRUE - if (status != "COMPLETE") warning("Query returned '", status, "'.", call. = FALSE) - .pkgenv[["query_status"]] <- status - break + estsz <- mapply(getResultSize, allnames, allvarnum, MoreArgs = list(qryptr = qryptr), SIMPLIFY = TRUE) + spdl::debug("['['] estimated result sizes {}", paste(estsz, collapse = ",")) + if (any(!is.na(estsz))) { + resrv <- max(estsz, na.rm = TRUE) + } else { + resrv <- resrv / 8 # character case where bytesize of offset vector was used + } + spdl::debug("['['] expected size {}", resrv) + ## Permit one pass to allow zero-row schema read + if (resrv == 0 && counter > 1L) { + finished <- TRUE + if (status != "COMPLETE") warning("Query returned '", status, "'.", call. = FALSE) + .pkgenv[["query_status"]] <- status + break + } + ## get results + getResult <- function(buf, name, varnum, estsz, qryptr) { + has_dumpbuffers <- length(x@dumpbuffers) > 0 + ## message("For ", name, " seeing ", estsz, " and ", varnum) + spdl::debug("[getResult] name {} estsz {} varnum {}", name, estsz, varnum) + if (is.na(varnum)) { + spdl::debug("[getResult] varnum before libtiledb_query_result_buffer_elements_vec") + vec <- libtiledb_query_result_buffer_elements_vec(qryptr, name) + if (has_dumpbuffers) { + vlcbuf_to_shmem(x@dumpbuffers, name, buf, vec) } - ## get results - getResult <- function(buf, name, varnum, estsz, qryptr) { - has_dumpbuffers <- length(x@dumpbuffers) > 0 - ## message("For ", name, " seeing ", estsz, " and ", varnum) - spdl::debug("[getResult] name {} estsz {} varnum {}", name, estsz, varnum) - if (is.na(varnum)) { - spdl::debug("[getResult] varnum before libtiledb_query_result_buffer_elements_vec"); - vec <- libtiledb_query_result_buffer_elements_vec(qryptr, name) - if (has_dumpbuffers) { - vlcbuf_to_shmem(x@dumpbuffers, name, buf, vec) - } - spdl::debug("[getResult] varnum before libtiledb_query_get_buffer_var_char"); - libtiledb_query_get_buffer_var_char(buf, vec[1], vec[2])[,1][seq_len(estsz)] - } else { - if (has_dumpbuffers) { - vecbuf_to_shmem(x@dumpbuffers, name, buf, estsz, varnum) - } - libtiledb_query_get_buffer_ptr(buf, asint64)[seq_len(estsz)] - spdl::debug("[getResult] calling libtiledb_query_get_buffer_ptr") - col <- libtiledb_query_get_buffer_ptr(buf, asint64)[seq_len(estsz)] - if (!is.null(dictionaries[[name]])) { # if there is a dictionary - dct <- dictionaries[[name]] # access it from utility - ord <- ordered_dict[[name]] - - col <- col + 1L # adjust for zero-index C/C++ layer - - if (inherits(col, "integer64")) # can happen when Python writes - col <- as.integer(col) - - ## special case from schema evolution could have added twice so correct - if (length(col) > 0 && min(col, na.rm=TRUE) == 2 && max(col, na.rm=TRUE) == length(dct) + 1) - col <- col - 1L - - if (inherits(dct, "character")) { - attr(col, "levels") <- dct - attr(col, "class") <- if (ord) c("ordered", "factor") else "factor" - } else { - col <- dct[col] - } - } - col - } + spdl::debug("[getResult] varnum before libtiledb_query_get_buffer_var_char") + libtiledb_query_get_buffer_var_char(buf, vec[1], vec[2])[, 1][seq_len(estsz)] + } else { + if (has_dumpbuffers) { + vecbuf_to_shmem(x@dumpbuffers, name, buf, estsz, varnum) } - spdl::debug("['['] getting results") - reslist <- mapply(getResult, buflist, allnames, allvarnum, estsz, - MoreArgs=list(qryptr=qryptr), SIMPLIFY=FALSE) - spdl::debug("['['] got results") - ## convert list into data.frame (possibly dealing with list columns) and subset - vnum <- 1 # default value of variable number of elements per cell - if (is.list(allvarnum)) allvarnum <- unlist(allvarnum) - if (length(allvarnum) > 0 && any(!is.na(allvarnum))) vnum <- max(allvarnum, na.rm=TRUE) - if (is.finite(vnum) && (vnum > 1)) { - ## turn to list col if a varnum != 1 (and not NA) seen - ind <- which(allvarnum != 1 & !is.na(allvarnum)) - for (k in ind) { - ncells <- allvarnum[k] - v <- reslist[[k]] - ## we split a vector v into 'list-columns' which element containing - ## ncells value (and we get ncells from the Array schema) - ## see https://stackoverflow.com/a/9547594/143305 for I() - ## and https://stackoverflow.com/a/3321659/143305 for split() - reslist[[k]] <- I(unname(split(v, ceiling(seq_along(v)/ncells)))) - } + libtiledb_query_get_buffer_ptr(buf, asint64)[seq_len(estsz)] + spdl::debug("[getResult] calling libtiledb_query_get_buffer_ptr") + col <- libtiledb_query_get_buffer_ptr(buf, asint64)[seq_len(estsz)] + if (!is.null(dictionaries[[name]])) { # if there is a dictionary + dct <- dictionaries[[name]] # access it from utility + ord <- ordered_dict[[name]] + + col <- col + 1L # adjust for zero-index C/C++ layer + + if (inherits(col, "integer64")) { # can happen when Python writes + col <- as.integer(col) + } + + ## special case from schema evolution could have added twice so correct + if (length(col) > 0 && min(col, na.rm = TRUE) == 2 && max(col, na.rm = TRUE) == length(dct) + 1) { + col <- col - 1L + } + + if (inherits(dct, "character")) { + attr(col, "levels") <- dct + attr(col, "class") <- if (ord) c("ordered", "factor") else "factor" + } else { + col <- dct[col] + } } - ## the list columns are now all of equal lenthth as R needs and we can form a data.frame - res <- data.frame(reslist)[,,drop=FALSE] - colnames(res) <- allnames - overallresults[[counter]] <- res + col + } } - spdl::debug("['['] completed {}", counter) - counter <- counter + 1L + spdl::debug("['['] getting results") + reslist <- mapply(getResult, buflist, allnames, allvarnum, estsz, + MoreArgs = list(qryptr = qryptr), SIMPLIFY = FALSE + ) + spdl::debug("['['] got results") + ## convert list into data.frame (possibly dealing with list columns) and subset + vnum <- 1 # default value of variable number of elements per cell + if (is.list(allvarnum)) allvarnum <- unlist(allvarnum) + if (length(allvarnum) > 0 && any(!is.na(allvarnum))) vnum <- max(allvarnum, na.rm = TRUE) + if (is.finite(vnum) && (vnum > 1)) { + ## turn to list col if a varnum != 1 (and not NA) seen + ind <- which(allvarnum != 1 & !is.na(allvarnum)) + for (k in ind) { + ncells <- allvarnum[k] + v <- reslist[[k]] + ## we split a vector v into 'list-columns' which element containing + ## ncells value (and we get ncells from the Array schema) + ## see https://stackoverflow.com/a/9547594/143305 for I() + ## and https://stackoverflow.com/a/3321659/143305 for split() + reslist[[k]] <- I(unname(split(v, ceiling(seq_along(v) / ncells)))) + } + } + ## the list columns are now all of equal lenthth as R needs and we can form a data.frame + res <- data.frame(reslist)[, , drop = FALSE] + colnames(res) <- allnames + overallresults[[counter]] <- res + } + spdl::debug("['['] completed {}", counter) + counter <- counter + 1L } - if (!use_arrow && requireNamespace("data.table", quietly=TRUE)) { # use very efficient rbindlist if available - res <- as.data.frame(data.table::rbindlist(overallresults)) + if (!use_arrow && requireNamespace("data.table", quietly = TRUE)) { # use very efficient rbindlist if available + res <- as.data.frame(data.table::rbindlist(overallresults)) } else { - res <- do.call(rbind, overallresults) + res <- do.call(rbind, overallresults) } spdl::debug("['['] returning 'res'") res - } # end of 'big else' for query build, submission and read + } # end of 'big else' for query build, submission and read - if (!use_arrow) { + if (!use_arrow) { ## convert to factor if that was asked if (x@strings_as_factors) { - for (n in colnames(res)) - if (is.character(res[[n]])) - res[[n]] <- as.factor(res[[n]]) + for (n in colnames(res)) { + if (is.character(res[[n]])) { + res[[n]] <- as.factor(res[[n]]) + } + } } ## reduce output if extended is false, or attrs given if (!x@extended) { - if (length(sel) > 0) { - res <- res[, if (sparse) allnames else attrnames, drop=FALSE] - } - k <- match("__tiledb_rows", colnames(res)) - if (is.finite(k)) { - res <- res[, -k, drop=FALSE] - } + if (length(sel) > 0) { + res <- res[, if (sparse) allnames else attrnames, drop = FALSE] + } + k <- match("__tiledb_rows", colnames(res)) + if (is.finite(k)) { + res <- res[, -k, drop = FALSE] + } } - } + } - spdl::debug("['['] before preparing final data form") - if (x@return_as == "asis") { + spdl::debug("['['] before preparing final data form") + if (x@return_as == "asis") { spdl::debug("['['] return asis") res <- as.list(res) - } else if (x@return_as == "array") { # if a conversion preference has been given, use it + } else if (x@return_as == "array") { # if a conversion preference has been given, use it res <- .convertToArray(dimnames, attrnames, res) - } else if (x@return_as == "matrix") { + } else if (x@return_as == "matrix") { res <- .convertToMatrix(res) - } else if (x@return_as == "data.frame") { - res <- as.data.frame(res) # should already be one per above - } else if (x@return_as == "data.table" && requireNamespace("data.table", quietly=TRUE)) { + } else if (x@return_as == "data.frame") { + res <- as.data.frame(res) # should already be one per above + } else if (x@return_as == "data.table" && requireNamespace("data.table", quietly = TRUE)) { res <- data.table::data.table(res) - } else if (x@return_as == "tibble" && requireNamespace("tibble", quietly=TRUE)) { + } else if (x@return_as == "tibble" && requireNamespace("tibble", quietly = TRUE)) { res <- tibble::as_tibble(res) - } else if (use_arrow) { + } else if (use_arrow) { ## possible list already collapsed above res - } + } - spdl::debug("['['] getting query status") - attr(res, "query_status") <- .pkgenv[["query_status"]] - if (x@query_statistics) + spdl::debug("['['] getting query status") + attr(res, "query_status") <- .pkgenv[["query_status"]] + if (x@query_statistics) { attr(res, "query_statistics") <- libtiledb_query_stats(qryptr) + } - spdl::debug("['['] returning result") - invisible(res) -}) + spdl::debug("['['] returning result") + invisible(res) + } +) ## helper functions .convertToMatrix <- function(res) { - ## special case of row and colnames and one attribute - if (typeof(res[,1]) == "character" && typeof(res[,2]) == "character" && ncol(res) == 3) { - dimnames <- list(unique(res[,1]), unique(res[,2])) - res <- matrix(res[,3], length(dimnames[[1]]), length(dimnames[[2]]), - dimnames=dimnames, byrow=TRUE) - return(invisible(res)) - } - k <- match("__tiledb_rows", colnames(res)) - if (is.finite(k)) { - res <- res[, -k] - } - if (ncol(res) < 3) { - stop("Seeing as.matrix argument with insufficient result set") - } - ## special case of integer64 - if (inherits(res[,1], "integer64")) { - res[,1] <- as.integer(res[,1]) - if (min(res[,1]) == 0) res[,1] <- res[,1] + 1 - } - if (ncol(res) >= 3 && inherits(res[,2], "integer64")) { - res[,2] <- as.integer(res[,2]) - if (min(res[,2]) == 0) res[,2] <- res[,2] + 1 - } - if (!identical(unique(res[,1]), seq(1, length(unique(res[,1]))))) { - cur <- unique(res[,1]) - for (l in seq_len(length(cur))) res[ which(res[,1] == cur[l]), 1 ] <- l - } - if (!identical(unique(res[,2]), seq(1, length(unique(res[,2]))))) { - cur <- unique(res[,2]) - for (l in seq_len(length(cur))) res[ which(res[,2] == cur[l]), 2 ] <- l - } - if (ncol(res) == 3) { - mat <- matrix(, nrow=max(res[,1]), ncol=max(res[,2])) - mat[ cbind( res[,1], res[,2] ) ] <- res[,3] - res <- mat - } else { # case of ncol > 3 - k <- ncol(res) - 2 - lst <- vector(mode = "list", length = k) - for (i in seq_len(k)) { - mat <- matrix(, nrow=max(res[,1]), ncol=max(res[,2])) - mat[ cbind( res[,1], res[,2] ) ] <- res[, 2 + i] - lst[[i]] <- mat - } - names(lst) <- tail(colnames(res), k) - res <- lst + ## special case of row and colnames and one attribute + if (typeof(res[, 1]) == "character" && typeof(res[, 2]) == "character" && ncol(res) == 3) { + dimnames <- list(unique(res[, 1]), unique(res[, 2])) + res <- matrix(res[, 3], length(dimnames[[1]]), length(dimnames[[2]]), + dimnames = dimnames, byrow = TRUE + ) + return(invisible(res)) + } + k <- match("__tiledb_rows", colnames(res)) + if (is.finite(k)) { + res <- res[, -k] + } + if (ncol(res) < 3) { + stop("Seeing as.matrix argument with insufficient result set") + } + ## special case of integer64 + if (inherits(res[, 1], "integer64")) { + res[, 1] <- as.integer(res[, 1]) + if (min(res[, 1]) == 0) res[, 1] <- res[, 1] + 1 + } + if (ncol(res) >= 3 && inherits(res[, 2], "integer64")) { + res[, 2] <- as.integer(res[, 2]) + if (min(res[, 2]) == 0) res[, 2] <- res[, 2] + 1 + } + if (!identical(unique(res[, 1]), seq(1, length(unique(res[, 1]))))) { + cur <- unique(res[, 1]) + for (l in seq_len(length(cur))) res[which(res[, 1] == cur[l]), 1] <- l + } + if (!identical(unique(res[, 2]), seq(1, length(unique(res[, 2]))))) { + cur <- unique(res[, 2]) + for (l in seq_len(length(cur))) res[which(res[, 2] == cur[l]), 2] <- l + } + if (ncol(res) == 3) { + mat <- matrix(, nrow = max(res[, 1]), ncol = max(res[, 2])) + mat[cbind(res[, 1], res[, 2])] <- res[, 3] + res <- mat + } else { # case of ncol > 3 + k <- ncol(res) - 2 + lst <- vector(mode = "list", length = k) + for (i in seq_len(k)) { + mat <- matrix(, nrow = max(res[, 1]), ncol = max(res[, 2])) + mat[cbind(res[, 1], res[, 2])] <- res[, 2 + i] + lst[[i]] <- mat } - res + names(lst) <- tail(colnames(res), k) + res <- lst + } + res } -.convertToArray <- function(dimnames,attrnames,res) { - dims <- sapply(dimnames, function(n) length(unique(res[,n])), USE.NAMES=FALSE) - if (prod(dims) != nrow(res)) { - message("Total array dimensions from unique elements does not match rows, returning data.frame unchanged.") - return(invisible(res)) - } - lst <- lapply(attrnames, function(n) array(res[,n], dim=dims)) - names(lst) <- attrnames - lst +.convertToArray <- function(dimnames, attrnames, res) { + dims <- sapply(dimnames, function(n) length(unique(res[, n])), USE.NAMES = FALSE) + if (prod(dims) != nrow(res)) { + message("Total array dimensions from unique elements does not match rows, returning data.frame unchanged.") + return(invisible(res)) + } + lst <- lapply(attrnames, function(n) array(res[, n], dim = dims)) + names(lst) <- attrnames + lst } #' Sets a tiledb array value or value range @@ -1188,280 +1262,296 @@ setMethod("[", "tiledb_array", #' @param value The value being assigned #' @return The modified object #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' \dontrun{ -#' uri <- "quickstart_sparse" ## as created by the other example -#' arr <- tiledb_array(uri) ## open array -#' df <- arr[] ## read current content +#' uri <- "quickstart_sparse" ## as created by the other example +#' arr <- tiledb_array(uri) ## open array +#' df <- arr[] ## read current content #' ## First approach: matching data.frame with appriate row and column -#' newdf <- data.frame(rows=c(1,2,2), cols=c(1,3,4), a=df$a+100) +#' newdf <- data.frame(rows = c(1, 2, 2), cols = c(1, 3, 4), a = df$a + 100) #' ## Second approach: supply indices explicitly -#' arr[c(1,2), c(1,3)] <- c(42,43) ## two values -#' arr[2, 4] <- 88 ## or just one +#' arr[c(1, 2), c(1, 3)] <- c(42, 43) ## two values +#' arr[2, 4] <- 88 ## or just one #' } #' @aliases [<-,tiledb_array #' @aliases [<-,tiledb_array-method #' @aliases [<-,tiledb_array,ANY,tiledb_array-method #' @aliases [<-,tiledb_array,ANY,ANY,tiledb_array-method -setMethod("[<-", "tiledb_array", - function(x, i, j, ..., value) { - if (!is.data.frame(value) && !(is.list(value) && length(value) > 1)) { - value <- as.data.frame(value) - if (nrow(value) == 0) { - message("Cannot assign zero row objects to TileDB Array.") - return(x) +setMethod( + "[<-", + "tiledb_array", + function(x, i, j, ..., value) { + if (!is.data.frame(value) && !(is.list(value) && length(value) > 1)) { + value <- as.data.frame(value) + if (nrow(value) == 0) { + message("Cannot assign zero row objects to TileDB Array.") + return(x) + } } - } - if (is.null(names(value))) stop("No column names supplied", call. = FALSE) - - ## add defaults - if (missing(i)) i <- NULL - if (missing(j)) j <- NULL - spdl::debug("[tiledb_array] '[<-' accessor started") - - ctx <- x@ctx - uri <- x@uri - sel <- x@attrs - sch <- tiledb::schema(x) - dom <- tiledb::domain(sch) - layout <- x@query_layout - asint64 <- x@datetimes_as_int64 - enckey <- x@encryption_key - tstamp <- x@timestamp_end - - sparse <- libtiledb_array_schema_sparse(sch@ptr) - - dims <- tiledb::dimensions(dom) - ndims <- length(dims) - dimnames <- sapply(dims, function(d) libtiledb_dim_get_name(d@ptr)) - dimtypes <- sapply(dims, function(d) libtiledb_dim_get_datatype(d@ptr)) - dimvarnum <- sapply(dims, function(d) libtiledb_dim_get_cell_val_num(d@ptr)) - dimnullable <- sapply(dims, function(d) FALSE) - dimdictionary <- sapply(dims, function(d) FALSE) - - attrs <- tiledb::attrs(schema(x)) - attrnames <- unname(sapply(attrs, function(a) libtiledb_attribute_get_name(a@ptr))) - attrtypes <- unname(sapply(attrs, function(a) libtiledb_attribute_get_type(a@ptr))) - attrvarnum <- unname(sapply(attrs, function(a) libtiledb_attribute_get_cell_val_num(a@ptr))) - attrnullable <- unname(sapply(attrs, function(a) libtiledb_attribute_get_nullable(a@ptr))) - attrdictionary <- unname(sapply(attrs, function(a) libtiledb_attribute_has_enumeration(ctx@ptr, a@ptr))) - - if (length(attrnames) > 0) { + if (is.null(names(value))) stop("No column names supplied", call. = FALSE) + + ## add defaults + if (missing(i)) i <- NULL + if (missing(j)) j <- NULL + spdl::debug("[tiledb_array] '[<-' accessor started") + + ctx <- x@ctx + uri <- x@uri + sel <- x@attrs + sch <- tiledb::schema(x) + dom <- tiledb::domain(sch) + layout <- x@query_layout + asint64 <- x@datetimes_as_int64 + enckey <- x@encryption_key + tstamp <- x@timestamp_end + + sparse <- libtiledb_array_schema_sparse(sch@ptr) + + dims <- tiledb::dimensions(dom) + ndims <- length(dims) + dimnames <- sapply(dims, function(d) libtiledb_dim_get_name(d@ptr)) + dimtypes <- sapply(dims, function(d) libtiledb_dim_get_datatype(d@ptr)) + dimvarnum <- sapply(dims, function(d) libtiledb_dim_get_cell_val_num(d@ptr)) + dimnullable <- sapply(dims, function(d) FALSE) + dimdictionary <- sapply(dims, function(d) FALSE) + + attrs <- tiledb::attrs(schema(x)) + attrnames <- unname(sapply(attrs, function(a) libtiledb_attribute_get_name(a@ptr))) + attrtypes <- unname(sapply(attrs, function(a) libtiledb_attribute_get_type(a@ptr))) + attrvarnum <- unname(sapply(attrs, function(a) libtiledb_attribute_get_cell_val_num(a@ptr))) + attrnullable <- unname(sapply(attrs, function(a) libtiledb_attribute_get_nullable(a@ptr))) + attrdictionary <- unname(sapply(attrs, function(a) libtiledb_attribute_has_enumeration(ctx@ptr, a@ptr))) + + if (length(attrnames) > 0) { allnames <- c(dimnames, attrnames) alltypes <- c(dimtypes, attrtypes) allvarnum <- c(dimvarnum, attrvarnum) allnullable <- c(dimnullable, attrnullable) alldictionary <- c(dimdictionary, attrdictionary) - } else { + } else { allnames <- dimnames alltypes <- dimtypes allvarnum <- dimvarnum allnullable <- dimnullable alldictionary <- dimdictionary - } + } - ## check we have complete columns (as we cannot write subset of attributes) - missing_names <- setdiff(attrnames, names(value)) - if (sparse - && length(missing_names) > 0 - && names(value)[1] != "value") { # special case of unnamed vector 'value' becoming one-col df - stop("Columns '", paste(missing_names, collapse=", "), "' are missing. Please add them", call. = FALSE) - } + ## check we have complete columns (as we cannot write subset of attributes) + missing_names <- setdiff(attrnames, names(value)) + if (sparse && + length(missing_names) > 0 && + names(value)[1] != "value") { # special case of unnamed vector 'value' becoming one-col df + stop("Columns '", paste(missing_names, collapse = ", "), "' are missing. Please add them", call. = FALSE) + } - ## we will recognize two standard cases - ## 1) arr[] <- value where value contains two columns with the dimnames - ## 2) arr[i,j] <- value where value contains just the attribute names - ## There is more to do here but it is a start + ## we will recognize two standard cases + ## 1) arr[] <- value where value contains two columns with the dimnames + ## 2) arr[i,j] <- value where value contains just the attribute names + ## There is more to do here but it is a start - ## Case 1 - if (length(colnames(value)) == length(allnames)) { + ## Case 1 + if (length(colnames(value)) == length(allnames)) { ## same length is good if (length(intersect(colnames(value), allnames)) == length(allnames)) { - ## all good, proceed - #message("Yay all columns found") - value <- value[, allnames, drop=FALSE] # reordering helps with append case + ## all good, proceed + # message("Yay all columns found") + value <- value[, allnames, drop = FALSE] # reordering helps with append case } else { - stop("Assigned data.frame does not contain all required attribute and dimension columns.") + stop("Assigned data.frame does not contain all required attribute and dimension columns.") } - } + } - ## Case 2 - if (sparse && length(colnames(value)) == length(attrnames)) { # FIXME: need to check for array or matrix arg? - if (is.null(i)) stop("For arrays a row index has to be supplied.") - if (is.null(j)) stop("For arrays a column index has to be supplied.") - #if (length(i) != nrow(value)) stop("Row index must have same number of observations as data") - if (length(j) == 1) j <- rep(j, nrow(value)) - ##if (length(colnames(value)) == 1 && colnames(value) == "value") colnames(value) <- attrnames - colnames(value) <- attrnames - newvalue <- data.frame(i, j) - colnames(newvalue) <- dimnames - value <- cbind(newvalue, value) - } + ## Case 2 + if (sparse && length(colnames(value)) == length(attrnames)) { # FIXME: need to check for array or matrix arg? + if (is.null(i)) stop("For arrays a row index has to be supplied.") + if (is.null(j)) stop("For arrays a column index has to be supplied.") + # if (length(i) != nrow(value)) stop("Row index must have same number of observations as data") + if (length(j) == 1) j <- rep(j, nrow(value)) + ## if (length(colnames(value)) == 1 && colnames(value) == "value") colnames(value) <- attrnames + colnames(value) <- attrnames + newvalue <- data.frame(i, j) + colnames(newvalue) <- dimnames + value <- cbind(newvalue, value) + } - ## Case 3: dense, length attributes == 1, i and j NULL - ## e.g. the quickstart_dense example where the RHS may be a matrix or data.frame - ## also need to guard against data.frame object which already have 'rows' and 'cols' - if (isFALSE(sparse) && - ##is.null(i) && is.null(j) && + ## Case 3: dense, length attributes == 1, i and j NULL + ## e.g. the quickstart_dense example where the RHS may be a matrix or data.frame + ## also need to guard against data.frame object which already have 'rows' and 'cols' + if (isFALSE(sparse) && + ## is.null(i) && is.null(j) && length(attrnames) == 1) { - d <- dim(value) - if ((d[2] > 1) && + d <- dim(value) + if ((d[2] > 1) && (inherits(value, "data.frame") || inherits(value, "matrix")) && !any(grepl("rows", colnames(value))) && - !any(grepl("cols", colnames(value))) ) { - ## turn the 2-d RHS in 1-d and align the names for the test that follows - ## in effect, we just rewrite the query for the user - value <- data.frame(x=as.matrix(value)[seq(1, d[1]*d[2])]) - colnames(value) <- attrnames + !any(grepl("cols", colnames(value)))) { + ## turn the 2-d RHS in 1-d and align the names for the test that follows + ## in effect, we just rewrite the query for the user + value <- data.frame(x = as.matrix(value)[seq(1, d[1] * d[2])]) + colnames(value) <- attrnames + allnames <- attrnames + alltypes <- attrtypes + allnullable <- attrnullable + alldictionary <- attrdictionary + } + + ## Case 4: dense, list on RHS e.g. the ex_1.R example + } else if (isFALSE(sparse) && + ## is.null(i) && is.null(j) && + length(value) == length(attrnames)) { + if (!inherits(value, "data.frame")) { + nl <- length(value) + for (k in seq_len(nl)) { + d <- dim(value[[k]]) + value[[k]] <- as.matrix(value[[k]])[seq(1, prod(d))] + } + } + names(value) <- attrnames allnames <- attrnames alltypes <- attrtypes allnullable <- attrnullable alldictionary <- attrdictionary } - ## Case 4: dense, list on RHS e.g. the ex_1.R example - } else if (isFALSE(sparse) && - ##is.null(i) && is.null(j) && - length(value) == length(attrnames)) { - if (!inherits(value, "data.frame")) { - nl <- length(value) - for (k in seq_len(nl)) { - d <- dim(value[[k]]) - value[[k]] <- as.matrix(value[[k]])[seq(1, prod(d))] - } - } - names(value) <- attrnames - allnames <- attrnames - alltypes <- attrtypes - allnullable <- attrnullable - alldictionary <- attrdictionary - } + nc <- if (is.list(value)) length(value) else ncol(value) + nm <- if (is.list(value)) names(value) else colnames(value) - nc <- if (is.list(value)) length(value) else ncol(value) - nm <- if (is.list(value)) names(value) else colnames(value) - - if (isTRUE(all.equal(sort(allnames),sort(nm)))) { - - if (libtiledb_array_is_open_for_writing(x@ptr)) { # if open for writing - arrptr <- x@ptr # use array - } else { # else open appropriately - if (length(enckey) > 0) { - if (length(tstamp) > 0) { - arrptr <- libtiledb_array_open_at_with_key(ctx@ptr, uri, "WRITE", enckey, tstamp) - } else { - arrptr <- libtiledb_array_open_with_key(ctx@ptr, uri, "WRITE", enckey) - } - } else { - if (length(tstamp) > 0) { - spdl::debug("['[<-'] openning for WRITE at {}", tstamp) - arrptr <- libtiledb_array_open_at(ctx@ptr, uri, "WRITE", tstamp) + if (isTRUE(all.equal(sort(allnames), sort(nm)))) { + if (libtiledb_array_is_open_for_writing(x@ptr)) { # if open for writing + arrptr <- x@ptr # use array + } else { # else open appropriately + if (length(enckey) > 0) { + if (length(tstamp) > 0) { + arrptr <- libtiledb_array_open_at_with_key(ctx@ptr, uri, "WRITE", enckey, tstamp) + } else { + arrptr <- libtiledb_array_open_with_key(ctx@ptr, uri, "WRITE", enckey) + } } else { - spdl::debug("['[<-'] openning for WRITE") - arrptr <- libtiledb_array_open(ctx@ptr, uri, "WRITE") + if (length(tstamp) > 0) { + spdl::debug("['[<-'] openning for WRITE at {}", tstamp) + arrptr <- libtiledb_array_open_at(ctx@ptr, uri, "WRITE", tstamp) + } else { + spdl::debug("['[<-'] openning for WRITE") + arrptr <- libtiledb_array_open(ctx@ptr, uri, "WRITE") + } } } - } - - qryptr <- libtiledb_query(ctx@ptr, arrptr, "WRITE") - qryptr <- libtiledb_query_set_layout(qryptr, - if (isTRUE(nchar(layout) > 0)) layout - else { if (sparse) "UNORDERED" else "COL_MAJOR" }) + qryptr <- libtiledb_query(ctx@ptr, arrptr, "WRITE") + qryptr <- libtiledb_query_set_layout( + qryptr, + if (isTRUE(nchar(layout) > 0)) { + layout + } else { + if (sparse) "UNORDERED" else "COL_MAJOR" + } + ) - buflist <- vector(mode="list", length=nc) - legacy_validity <- libtiledb_query_buffer_var_char_get_legacy_validity_value(ctx@ptr) + buflist <- vector(mode = "list", length = nc) + legacy_validity <- libtiledb_query_buffer_var_char_get_legacy_validity_value(ctx@ptr) - for (colnam in allnames) { - ## when an index column is use this may be unordered to remap to position in 'nm' names - k <- match(colnam, nm) + for (colnam in allnames) { + ## when an index column is use this may be unordered to remap to position in 'nm' names + k <- match(colnam, nm) - if (alldictionary[k]) { + if (alldictionary[k]) { spdl::trace("[tiledb_array] '[<-' column {} ({}) is factor", colnam, k) new_levels <- levels(value[[k]]) attr <- attrs[[allnames[k]]] tpstr <- tiledb_attribute_get_enumeration_type_ptr(attr, arrptr) if (tpstr %in% c("ASCII", "UTF8")) { - dictionary <- tiledb_attribute_get_enumeration_ptr(attr, arrptr) - } else if (tpstr %in% c("FLOAT32", "FLOAT64", "BOOL", "UINT8", "UINT16", "UINT32", "UINT64", - "INT8", "INT16", "INT32", "INT64")) { - dictionary <- tiledb_attribute_get_enumeration_vector_ptr(attr, arrptr) + dictionary <- tiledb_attribute_get_enumeration_ptr(attr, arrptr) + } else if (tpstr %in% c( + "FLOAT32", "FLOAT64", "BOOL", "UINT8", "UINT16", "UINT32", "UINT64", + "INT8", "INT16", "INT32", "INT64" + )) { + dictionary <- tiledb_attribute_get_enumeration_vector_ptr(attr, arrptr) } else { - stop("Unsupported enumeration vector payload of type '", tpstr, "'.", call. = FALSE) + stop("Unsupported enumeration vector payload of type '", tpstr, "'.", call. = FALSE) } added_enums <- setdiff(new_levels, dictionary) if (length(added_enums) > 0) { - maxval <- tiledb_datatype_max_value(alltypes[k]) + 1 # R vectors are 1-indexed - spdl::debug("[tiledb_array] '[<-' Adding levels '{}' at '{}' {} ({} + {} ? {})", - paste(added_enums, collapse=","), allnames[k], alltypes[k], length(dictionary), length(added_enums), maxval); - if (length(dictionary) + length(added_enums) > maxval) { - stop(sprintf("For column '%s' cannot add %d factor levels to existing %d for type '%s' with maximum value %d", - colnam, length(added_enums), length(dictionary), alltypes[k], maxval), call. = FALSE) - } - levels <- unique(c(dictionary, new_levels)) - is_ordered <- tiledb_attribute_is_ordered_enumeration_ptr(attr, arrptr) - value[[k]] <- factor(value[[k]], levels = levels, ordered = is_ordered) - spdl::trace("[tiledb_array] '[<-' releveled column {} {}", k, is_ordered) - ase <- tiledb_array_schema_evolution() - if (!tiledb_array_is_open(x)) - arr <- tiledb_array_open(x) - else - arr <- x - ase <- tiledb_array_schema_evolution_extend_enumeration(ase, arr, allnames[k], added_enums) - tiledb::tiledb_array_schema_evolution_array_evolve(ase, uri) - value[[k]] <- factor(value[[k]], levels = unique(c(dictionary, added_enums)), ordered=is.ordered(value[[k]])) + maxval <- tiledb_datatype_max_value(alltypes[k]) + 1 # R vectors are 1-indexed + spdl::debug( + "[tiledb_array] '[<-' Adding levels '{}' at '{}' {} ({} + {} ? {})", + paste(added_enums, collapse = ","), allnames[k], alltypes[k], length(dictionary), length(added_enums), maxval + ) + if (length(dictionary) + length(added_enums) > maxval) { + stop(sprintf( + "For column '%s' cannot add %d factor levels to existing %d for type '%s' with maximum value %d", + colnam, length(added_enums), length(dictionary), alltypes[k], maxval + ), call. = FALSE) + } + levels <- unique(c(dictionary, new_levels)) + is_ordered <- tiledb_attribute_is_ordered_enumeration_ptr(attr, arrptr) + value[[k]] <- factor(value[[k]], levels = levels, ordered = is_ordered) + spdl::trace("[tiledb_array] '[<-' releveled column {} {}", k, is_ordered) + ase <- tiledb_array_schema_evolution() + if (!tiledb_array_is_open(x)) { + arr <- tiledb_array_open(x) + } else { + arr <- x + } + ase <- tiledb_array_schema_evolution_extend_enumeration(ase, arr, allnames[k], added_enums) + tiledb::tiledb_array_schema_evolution_array_evolve(ase, uri) + value[[k]] <- factor(value[[k]], levels = unique(c(dictionary, added_enums)), ordered = is.ordered(value[[k]])) } - } + } - if (alltypes[k] %in% c("CHAR", "ASCII", "UTF8")) { # variable length - txtvec <- as.character(value[[k]]) - spdl::debug("[tiledb_array] '[<-' alloc char buffer {} '{}': {}", k, colnam, alltypes[k]) - buflist[[k]] <- libtiledb_query_buffer_var_char_create(txtvec, allnullable[k], legacy_validity) - qryptr <- libtiledb_query_set_buffer_var_char(qryptr, colnam, buflist[[k]]) - } else { - col <- value[[k]] - if (is.list(col)) { + if (alltypes[k] %in% c("CHAR", "ASCII", "UTF8")) { # variable length + txtvec <- as.character(value[[k]]) + spdl::debug("[tiledb_array] '[<-' alloc char buffer {} '{}': {}", k, colnam, alltypes[k]) + buflist[[k]] <- libtiledb_query_buffer_var_char_create(txtvec, allnullable[k], legacy_validity) + qryptr <- libtiledb_query_set_buffer_var_char(qryptr, colnam, buflist[[k]]) + } else { + col <- value[[k]] + if (is.list(col)) { col <- unname(do.call(c, col)) + } + if (is.factor(col)) { + col <- as.integer(col) - 1L # zero based in C++ so offsetting + } + nr <- NROW(col) + spdl::debug("[tiledb_array] '[<-' alloc buf {} '{}': {}, rows: {} null: {} asint64: {}", k, colnam, alltypes[k], nr, allnullable[k], asint64) + buflist[[k]] <- libtiledb_query_buffer_alloc_ptr(alltypes[k], nr, allnullable[k], allvarnum[k]) + buflist[[k]] <- libtiledb_query_buffer_assign_ptr(buflist[[k]], alltypes[k], col, asint64) + qryptr <- libtiledb_query_set_buffer_ptr(qryptr, colnam, buflist[[k]]) } - if (is.factor(col)) { - col <- as.integer(col) - 1L # zero based in C++ so offsetting - } - nr <- NROW(col) - spdl::debug("[tiledb_array] '[<-' alloc buf {} '{}': {}, rows: {} null: {} asint64: {}", k, colnam, alltypes[k], nr, allnullable[k], asint64) - buflist[[k]] <- libtiledb_query_buffer_alloc_ptr(alltypes[k], nr, allnullable[k], allvarnum[k]) - buflist[[k]] <- libtiledb_query_buffer_assign_ptr(buflist[[k]], alltypes[k], col, asint64) - qryptr <- libtiledb_query_set_buffer_ptr(qryptr, colnam, buflist[[k]]) } - } - - ## case of dense array with subarray writes needs to set the subarray - if (!sparse && !is.null(i) && !is.null(j) && length(allnames) == 1) { - if (!is.vector(i) || !is.vector(j)) message("'i' and 'j' should be simple vectors.") - subarr <- as.integer(c(range(i), range(j))) - qryptr <- libtiledb_query_set_subarray(qryptr, subarr) - } - qryptr <- libtiledb_query_submit(qryptr) - if (!x@keep_open) libtiledb_array_close(arrptr) + ## case of dense array with subarray writes needs to set the subarray + if (!sparse && !is.null(i) && !is.null(j) && length(allnames) == 1) { + if (!is.vector(i) || !is.vector(j)) message("'i' and 'j' should be simple vectors.") + subarr <- as.integer(c(range(i), range(j))) + qryptr <- libtiledb_query_set_subarray(qryptr, subarr) + } + qryptr <- libtiledb_query_submit(qryptr) + if (!x@keep_open) libtiledb_array_close(arrptr) + } + invisible(x) } - invisible(x) -}) - +) ## -- as.data.frame accessor (generic in DenseArray.R) #' Retrieve data.frame return toggle #' #' A \code{tiledb_array} object can be returned as an array (or list of arrays), -#' or, if select, as a \code{data.frame}. This methods returns the selection value. +#' or, if select, as a \code{data.frame}. This methods returns the +#' selection value. #' @param object A \code{tiledb_array} object -#' @return A logical value indicating whether \code{data.frame} return is selected +#' @return A logical value indicating whether \code{data.frame} return +#' is selected #' @export -setMethod("return.data.frame", - signature = "tiledb_array", - function(object) object@as.data.frame) - +setMethod( + "return.data.frame", + signature = "tiledb_array", + function(object) object@as.data.frame +) ## -- as.data.frame setter (generic in DenseArray.R) @@ -1473,59 +1563,64 @@ setMethod("return.data.frame", #' @param value A logical value with the selection #' @return The modified \code{tiledb_array} array object #' @export -setReplaceMethod("return.data.frame", - signature = "tiledb_array", - function(x, value) { - x@as.data.frame <- value - validObject(x) - x -}) - - +setReplaceMethod( + "return.data.frame", + signature = "tiledb_array", + function(x, value) { + x@as.data.frame <- value + validObject(x) + x + } +) ## -- attrs (generic in Attributes.R and DenseArray.R) #' Retrieve attributes from \code{tiledb_array} object #' #' By default, all attributes will be selected. But if a subset of attribute -#' names is assigned to the internal slot \code{attrs}, then only those attributes -#' will be queried. This methods accesses the slot. +#' names is assigned to the internal slot \code{attrs}, then only those +#' attributes#' will be queried. This methods accesses the slot. #' @param object A \code{tiledb_array} object #' @return An empty character vector if no attributes have been selected or else #' a vector with attributes; \code{NA} means no attributes will be returned. #' @importFrom methods validObject #' @export -setMethod("attrs", - signature = "tiledb_array", - function(object) object@attrs) +setMethod( + "attrs", + signature = "tiledb_array", + function(object) object@attrs +) #' Selects attributes for the given TileDB array #' #' @param x A \code{tiledb_array} object -#' @param value A character vector with attributes; the value \code{NA_character_} -#' signals no attributes should be returned; default is an empty character vector -#' implying all columns are returned. +#' @param value A character vector with attributes; the value +#' \code{NA_character_} signals no attributes should be returned; default is an +#' empty character vector implying all columns are returned. #' @return The modified \code{tiledb_array} object #' @export -setReplaceMethod("attrs", - signature = "tiledb_array", - function(x, value) { - nm <- names(attrs(schema(x))) - value_is_na <- length(value) == 1 && is.na(value) # no attribute query - if (length(nm) == 0 || value_is_na) { # none set so far - x@attrs <- value - } else { - pm <- pmatch(value, nm) - if (any(is.na(pm))) { - stop("Multiple partial matches ambiguous: ", - paste(value[which(is.na(pm))], collapse=","), call.=FALSE) +setReplaceMethod( + "attrs", + signature = "tiledb_array", + function(x, value) { + nm <- names(attrs(schema(x))) + value_is_na <- length(value) == 1 && is.na(value) # no attribute query + if (length(nm) == 0 || value_is_na) { # none set so far + x@attrs <- value + } else { + pm <- pmatch(value, nm) + if (any(is.na(pm))) { + stop("Multiple partial matches ambiguous: ", + paste(value[which(is.na(pm))], collapse = ","), + call. = FALSE + ) + } + x@attrs <- nm[pm] } - x@attrs <- nm[pm] + validObject(x) + x } - validObject(x) - x -}) - +) ## -- extended accessor @@ -1539,122 +1634,150 @@ setGeneric("extended<-", function(x, value) standardGeneric("extended<-")) #' Retrieve data.frame extended returns columns toggle #' -#' A \code{tiledb_array} object can be returned as \code{data.frame}. This methods -#' returns the selection value for \sQuote{extended} format including row (and column, -#' if present) indices. +#' A \code{tiledb_array} object can be returned as \code{data.frame}. This +#' methods returns the selection value for \sQuote{extended} format including +#' row (and column, if present) indices. #' @param object A \code{tiledb_array} object -#' @return A logical value indicating whether an \code{extended} return is selected +#' @return A logical value indicating whether an \code{extended} +#' return is selected #' @export -setMethod("extended", - signature = "tiledb_array", - function(object) object@extended) - +setMethod( + "extended", + signature = "tiledb_array", + function(object) object@extended +) ## -- extended setter (generic in DenseArray.R) #' Set data.frame extended return columns toggle #' -#' A \code{tiledb_array} object can be returned as \code{data.frame}. This methods -#' set the selection value for \sQuote{extended} format including row (and column, -#' if present) indices. +#' A \code{tiledb_array} object can be returned as \code{data.frame}. This +#' methods set the selection value for \sQuote{extended} format including row +#' (and column, if present) indices. #' @param x A \code{tiledb_array} object #' @param value A logical value with the selection #' @return The modified \code{tiledb_array} array object #' @export -setReplaceMethod("extended", - signature = "tiledb_array", - function(x, value) { - x@extended <- value - validObject(x) - x -}) - +setReplaceMethod( + "extended", + signature = "tiledb_array", + function(x, value) { + x@extended <- value + validObject(x) + x + } +) ## -- selected_ranges accessor #' @rdname selected_ranges-tiledb_array-method #' @export -setGeneric("selected_ranges", function(object) standardGeneric("selected_ranges")) +setGeneric( + "selected_ranges", + function(object) standardGeneric("selected_ranges")) #' @rdname selected_ranges-set-tiledb_array-method #' @export -setGeneric("selected_ranges<-", function(x, value) standardGeneric("selected_ranges<-")) +setGeneric( + "selected_ranges<-", + function(x, value) standardGeneric("selected_ranges<-")) #' Retrieve selected_ranges values for the array #' #' A \code{tiledb_array} object can have a range selection for each dimension -#' attribute. This methods returns the selection value for \sQuote{selected_ranges} -#' and returns a list (with one element per dimension) of two-column matrices where -#' each row describes one pair of minimum and maximum values. Alternatively, the list -#' can be named with the names providing the match to the corresponding dimension. +#' attribute. This methods returns the selection value for +#' \sQuote{selected_ranges} and returns a list (with one element per dimension) +#' of two-column matrices where each row describes one pair of minimum and +#' maximum values. Alternatively, the list can be named with the names providing +#' the match to the corresponding dimension. #' @param object A \code{tiledb_array} object #' @return A list which can contain a matrix for each dimension #' @export -setMethod("selected_ranges", signature = "tiledb_array", - function(object) object@selected_ranges) +setMethod( + "selected_ranges", + signature = "tiledb_array", + function(object) object@selected_ranges +) #' Set selected_ranges return values for the array #' #' A \code{tiledb_array} object can have a range selection for each dimension #' attribute. This methods sets the selection value for \sQuote{selected_ranges} #' which is a list (with one element per dimension) of two-column matrices where -#' each row describes one pair of minimum and maximum values. Alternatively, the list -#' can be named with the names providing the match to the corresponding dimension. +#' each row describes one pair of minimum and maximum values. Alternatively, +#' the list can be named with the names providing the match to the +#' corresponding dimension. #' @param x A \code{tiledb_array} object #' @param value A list of two-column matrices where each list element \sQuote{i} -#' corresponds to the dimension attribute \sQuote{i}. The matrices can contain rows -#' where each row contains the minimum and maximum value of a range. +#' corresponds to the dimension attribute \sQuote{i}. The matrices can contain +#' rows where each row contains the minimum and maximum value of a range. #' @return The modified \code{tiledb_array} array object #' @export -setReplaceMethod("selected_ranges", signature = "tiledb_array", - function(x, value) { - x@selected_ranges <- value - validObject(x) - x -}) +setReplaceMethod( + "selected_ranges", + signature = "tiledb_array", + function(x, value) { + x@selected_ranges <- value + validObject(x) + x + } +) ## -- selected_points accessor #' @rdname selected_points-tiledb_array-method #' @export -setGeneric("selected_points", function(object) standardGeneric("selected_points")) +setGeneric( + "selected_points", + function(object) standardGeneric("selected_points") +) #' @rdname selected_points-set-tiledb_array-method #' @export -setGeneric("selected_points<-", function(x, value) standardGeneric("selected_points<-")) +setGeneric( + "selected_points<-", + function(x, value) standardGeneric("selected_points<-") +) #' Retrieve selected_points values for the array #' #' A \code{tiledb_array} object can have a range selection for each dimension -#' attribute. This methods returns the selection value for \sQuote{selected_points} -#' and returns a list (with one element per dimension) of vectors where -#' each row describes one selected points. Alternatively, the list -#' can be named with the names providing the match to the corresponding dimension. +#' attribute. This methods returns the selection value for +#' \sQuote{selected_points} and returns a list (with one element per dimension) +#' of vectors where each row describes one selected points. Alternatively, the +#' list can be named with the names providing the match to the +#' corresponding dimension. #' @param object A \code{tiledb_array} object #' @return A list which can contain a vector for each dimension #' @export -setMethod("selected_points", signature = "tiledb_array", - function(object) object@selected_points) +setMethod( + "selected_points", + signature = "tiledb_array", + function(object) object@selected_points +) #' Set selected_points return values for the array #' #' A \code{tiledb_array} object can have a range selection for each dimension #' attribute. This methods sets the selection value for \sQuote{selected_points} #' which is a list (with one element per dimension) of two-column matrices where -#' each row describes one pair of minimum and maximum values. Alternatively, the list -#' can be named with the names providing the match to the corresponding dimension. +#' each row describes one pair of minimum and maximum values. Alternatively, the +#' list can be named with the names providing the match to the +#' corresponding dimension. #' @param x A \code{tiledb_array} object #' @param value A list of vectors where each list element \sQuote{i} #' corresponds to the dimension attribute \sQuote{i}. #' @return The modified \code{tiledb_array} array object #' @export -setReplaceMethod("selected_points", signature = "tiledb_array", - function(x, value) { - x@selected_points <- value - validObject(x) - x -}) - +setReplaceMethod( + "selected_points", + signature = "tiledb_array", + function(x, value) { + x@selected_points <- value + validObject(x) + x + } +) ## -- query_layout accessor @@ -1664,13 +1787,16 @@ setGeneric("query_layout", function(object) standardGeneric("query_layout")) #' @rdname query_layout-set-tiledb_array-method #' @export -setGeneric("query_layout<-", function(x, value) standardGeneric("query_layout<-")) +setGeneric( + "query_layout<-", + function(x, value) standardGeneric("query_layout<-") +) #' Retrieve query_layout values for the array #' -#' A \code{tiledb_array} object can have a corresponding query with a given layout -#' given layout. This methods returns the selection value for \sQuote{query_layout} -#' as a character value. +#' A \code{tiledb_array} object can have a corresponding query with a given +#' layout given layout. This methods returns the selection value for +#' \sQuote{query_layout} as a character value. #' @param object A \code{tiledb_array} object #' @return A character value describing the query layout #' @export @@ -1678,200 +1804,230 @@ setMethod("query_layout", signature = "tiledb_array", function(object) object@qu #' Set query_layout return values for the array #' -#' A \code{tiledb_array} object can have an associated query with a specific layout. -#' This methods sets the selection value for \sQuote{query_layout} from a character -#' value. +#' A \code{tiledb_array} object can have an associated query with a specific +#' layout. This methods sets the selection value for \sQuote{query_layout} +#' from a character value. #' @param x A \code{tiledb_array} object #' -#' @param value A character variable for the query layout. Permitted values are -#' \dQuote{ROW_MAJOR}, \dQuote{COL_MAJOR}, \dQuote{GLOBAL_ORDER}, or \dQuote{UNORDERD}. +#' @param value A character variable for the query layout. Permitted values +#' are \dQuote{ROW_MAJOR}, \dQuote{COL_MAJOR}, \dQuote{GLOBAL_ORDER}, or +#' \dQuote{UNORDERD}. #' @return The modified \code{tiledb_array} array object #' @export -setReplaceMethod("query_layout", signature = "tiledb_array", function(x, value) { - x@query_layout <- value - validObject(x) - x -}) - - +setReplaceMethod( + "query_layout", + signature = "tiledb_array", + function(x, value) { + x@query_layout <- value + validObject(x) + x + } +) ## -- datetimes_as_int64 accessor #' @rdname datetimes_as_int64-tiledb_array-method #' @export -setGeneric("datetimes_as_int64", function(object) standardGeneric("datetimes_as_int64")) +setGeneric( + "datetimes_as_int64", + function(object) standardGeneric("datetimes_as_int64") +) #' @rdname datetimes_as_int64-set-tiledb_array-method #' @export -setGeneric("datetimes_as_int64<-", function(x, value) standardGeneric("datetimes_as_int64<-")) +setGeneric( + "datetimes_as_int64<-", + function(x, value) standardGeneric("datetimes_as_int64<-") +) #' Retrieve datetimes_as_int64 toggle #' -#' A \code{tiledb_array} object may contain date and datetime objects. While their internal -#' representation is generally shielded from the user, it can useful to access them as the -#' \sQuote{native} format which is an \code{integer64}. This function retrieves the current -#' value of the selection variable, which has a default of \code{FALSE}. +#' A \code{tiledb_array} object may contain date and datetime objects. While +#' their internal representation is generally shielded from the user, it can +#' useful to access them as the \sQuote{native} format which is an +#' \code{integer64}. This function retrieves the current value of the selection +#' variable, which has a default of \code{FALSE}. #' @param object A \code{tiledb_array} object -#' @return A logical value indicating whether \code{datetimes_as_int64} is selected +#' @return A logical value indicating whether \code{datetimes_as_int64} +#' is selected #' @export -setMethod("datetimes_as_int64", - signature = "tiledb_array", - function(object) object@datetimes_as_int64) - +setMethod( + "datetimes_as_int64", + signature = "tiledb_array", + function(object) object@datetimes_as_int64 +) ## -- datetimes_as_int64 setter (generic in DenseArray.R) #' Set datetimes_as_int64 toggle #' -#' A \code{tiledb_array} object may contain date and datetime objects. While their internal -#' representation is generally shielded from the user, it can useful to access them as the -#' \sQuote{native} format which is an \code{integer64}. This function set the current -#' value of the selection variable, which has a default of \code{FALSE}. +#' A \code{tiledb_array} object may contain date and datetime objects. While +#' their internal representation is generally shielded from the user, it can +#' useful to access them as the \sQuote{native} format which is an +#' \code{integer64}. This function set the current value of the selection +#' variable, which has a default of \code{FALSE}. #' @param x A \code{tiledb_array} object #' @param value A logical value with the selection #' @return The modified \code{tiledb_array} array object #' @export -setReplaceMethod("datetimes_as_int64", - signature = "tiledb_array", - function(x, value) { - x@datetimes_as_int64 <- value - validObject(x) - x -}) - +setReplaceMethod( + "datetimes_as_int64", + signature = "tiledb_array", + function(x, value) { + x@datetimes_as_int64 <- value + validObject(x) + x + } +) ## -- consolitate wrapper #' Consolidate fragments of a TileDB Array #' -#' This function invokes a consolidation operation. Parameters affecting the operation -#' can be set via an optional configuration object. Start and end timestamps can also be -#' set directly. +#' This function invokes a consolidation operation. Parameters affecting the +#' operation can be set via an optional configuration object. Start and end +#' timestamps can also be set directly. #' @param uri A character value with the URI of a TileDB Array -#' @param start_time An optional timestamp value, if missing config default is used +#' @param start_time An optional timestamp value, if missing config +#' default is used #' @param end_time An optional timestamp value, if missing config default is used #' @param cfg An optional TileDB Configuration object #' @param ctx An option TileDB Context object #' @return NULL is returned invisibly #' @export -array_consolidate <- function(uri, cfg = NULL, - start_time, end_time, - ctx = tiledb_get_context()) { - stopifnot(`Argument 'uri' must be character` = is.character(uri)) - if (is.null(cfg)) { - cfg <- config(ctx) - } +array_consolidate <- function( + uri, + cfg = NULL, + start_time, + end_time, + ctx = tiledb_get_context() +) { + stopifnot(`Argument 'uri' must be character` = is.character(uri)) + if (is.null(cfg)) { + cfg <- config(ctx) + } - if (!missing(start_time)) { - stopifnot(`Argument 'start_time' must be datetime object` = inherits(start_time, "POSIXt")) - start_time_int64 <- bit64::as.integer64(as.numeric(start_time) * 1000) - cfg["sm.consolidation.timestamp_start"] = as.character(start_time_int64) - } + if (!missing(start_time)) { + stopifnot(`Argument 'start_time' must be datetime object` = inherits(start_time, "POSIXt")) + start_time_int64 <- bit64::as.integer64(as.numeric(start_time) * 1000) + cfg["sm.consolidation.timestamp_start"] <- as.character(start_time_int64) + } - if (!missing(end_time)) { - stopifnot(`Argument 'end_time' must be datetime object` = inherits(end_time, "POSIXt")) - end_time_int64 <- bit64::as.integer64(as.numeric(end_time) * 1000) - cfg["sm.consolidation.timestamp_end"] = as.character(end_time_int64) - } + if (!missing(end_time)) { + stopifnot(`Argument 'end_time' must be datetime object` = inherits(end_time, "POSIXt")) + end_time_int64 <- bit64::as.integer64(as.numeric(end_time) * 1000) + cfg["sm.consolidation.timestamp_end"] <- as.character(end_time_int64) + } - ctx <- tiledb_ctx(cfg) + ctx <- tiledb_ctx(cfg) - libtiledb_array_consolidate(ctx = ctx@ptr, uri = uri, cfgptr = cfg@ptr) + libtiledb_array_consolidate(ctx = ctx@ptr, uri = uri, cfgptr = cfg@ptr) } #' After consolidation, remove consolidated fragments of a TileDB Array #' -#' This function can remove fragments following a consolidation step. Note that vacuuming -#' should \emph{not} be run if one intends to use the TileDB \emph{time-traveling} feature -#' of opening arrays at particular timestamps. +#' This function can remove fragments following a consolidation step. Note that +#' vacuuming should \emph{not} be run if one intends to use the TileDB +#' \emph{time-traveling} feature of opening arrays at particular timestamps. #' -#' Parameters affecting the operation can be set via an optional configuration object. -#' Start and end timestamps can also be set directly. +#' Parameters affecting the operation can be set via an optional configuration +#' object. Start and end timestamps can also be set directly. #' #' @param uri A character value with the URI of a TileDB Array -#' @param start_time An optional timestamp value, if missing config default is used -#' @param end_time An optional timestamp value, if missing config default is used +#' @param start_time An optional timestamp value, if missing config +#' default is used +#' @param end_time An optional timestamp value, if missing config default +#' is used #' @param cfg An optional TileDB Configuration object #' @param ctx An option TileDB Context object #' @return NULL is returned invisibly #' @export -array_vacuum <- function(uri, cfg = NULL, - start_time, end_time, - ctx = tiledb_get_context()) { - - stopifnot(`Argument 'uri' must be character` = is.character(uri)) - if (is.null(cfg)) { - cfg <- config(ctx) - } +array_vacuum <- function( + uri, + cfg = NULL, + start_time, + end_time, + ctx = tiledb_get_context() +) { + stopifnot(`Argument 'uri' must be character` = is.character(uri)) + if (is.null(cfg)) { + cfg <- config(ctx) + } - if (!missing(start_time)) { - stopifnot(`Argument 'start_time' must be datetime object` = inherits(start_time, "POSIXt")) - start_time_int64 <- bit64::as.integer64(as.numeric(start_time) * 1000) - cfg["sm.consolidation.timestamp_start"] = as.character(start_time_int64) - } + if (!missing(start_time)) { + stopifnot(`Argument 'start_time' must be datetime object` = inherits(start_time, "POSIXt")) + start_time_int64 <- bit64::as.integer64(as.numeric(start_time) * 1000) + cfg["sm.consolidation.timestamp_start"] <- as.character(start_time_int64) + } - if (!missing(end_time)) { - stopifnot(`Argument 'end_time' must be datetime object` = inherits(end_time, "POSIXt")) - end_time_int64 <- bit64::as.integer64(as.numeric(end_time) * 1000) - cfg["sm.consolidation.timestamp_end"] = as.character(end_time_int64) - } + if (!missing(end_time)) { + stopifnot(`Argument 'end_time' must be datetime object` = inherits(end_time, "POSIXt")) + end_time_int64 <- bit64::as.integer64(as.numeric(end_time) * 1000) + cfg["sm.consolidation.timestamp_end"] <- as.character(end_time_int64) + } - ctx <- tiledb_ctx(cfg) + ctx <- tiledb_ctx(cfg) - libtiledb_array_vacuum(ctx = ctx@ptr, uri = uri, cfgptr = cfg@ptr) + libtiledb_array_vacuum(ctx = ctx@ptr, uri = uri, cfgptr = cfg@ptr) } #' Get the non-empty domain from a TileDB Array by index #' -#' This functions works for both fixed- and variable-sized dimensions and switches -#' internally. +#' This functions works for both fixed- and variable-sized dimensions and +#' switches internally. +#' #' @param arr A TileDB Array #' @param idx An integer index between one the number of dimensions #' @return A two-element object is returned describing the domain of selected #' dimension; it will either be a numeric vector in case of a fixed-size -#' fixed-sized dimensions, or a characer vector for a variable-sized one. +#' fixed-sized dimensions, or a character vector for a variable-sized one. #' @export tiledb_array_get_non_empty_domain_from_index <- function(arr, idx) { - stopifnot(`Argument 'arr' must be a tiledb_array` = is(arr, "tiledb_array"), - `Argument 'idx' must be numeric and positive` = is.numeric(idx) && idx > 0, - `Argument 'arr' must be open` = libtiledb_array_is_open(arr@ptr)) + stopifnot( + `Argument 'arr' must be a tiledb_array` = is(arr, "tiledb_array"), + `Argument 'idx' must be numeric and positive` = is.numeric(idx) && idx > 0, + `Argument 'arr' must be open` = libtiledb_array_is_open(arr@ptr) + ) sch <- schema(arr) dom <- domain(sch) dims <- dimensions(dom) dimtypes <- sapply(dims, function(d) libtiledb_dim_get_datatype(d@ptr)) dimvarnum <- sapply(dims, function(d) libtiledb_dim_get_cell_val_num(d@ptr)) - if (is.na(dimvarnum[idx])) - libtiledb_array_get_non_empty_domain_var_from_index(arr@ptr, idx-1) - else - libtiledb_array_get_non_empty_domain_from_index(arr@ptr, idx-1, dimtypes[idx]) - + if (is.na(dimvarnum[idx])) { + libtiledb_array_get_non_empty_domain_var_from_index(arr@ptr, idx - 1) + } else { + libtiledb_array_get_non_empty_domain_from_index(arr@ptr, idx - 1, dimtypes[idx]) + } } #' Get the non-empty domain from a TileDB Array by name #' -#' This functions works for both fixed- and variable-sized dimensions and switches -#' internally. +#' This functions works for both fixed- and variable-sized dimensions and +#' switches internally. +#' #' @param arr A TileDB Array #' @param name An character variable with a dimension name #' @return A two-element object is returned describing the domain of selected #' dimension; it will either be a numeric vector in case of a fixed-size -#' fixed-sized dimensions, or a characer vector for a variable-sized one. +#' fixed-sized dimensions, or a character vector for a variable-sized one. #' @export tiledb_array_get_non_empty_domain_from_name <- function(arr, name) { - stopifnot(`Argument 'arr' must be a tiledb_array` = is(arr, "tiledb_array"), - `Argument 'name' must be character` = is.character(name), - `Argument 'arr' must be open` = libtiledb_array_is_open(arr@ptr)) + stopifnot( + `Argument 'arr' must be a tiledb_array` = is(arr, "tiledb_array"), + `Argument 'name' must be character` = is.character(name), + `Argument 'arr' must be open` = libtiledb_array_is_open(arr@ptr) + ) - sch <- schema(arr) - dom <- domain(sch) - dims <- dimensions(dom) - dimnames <- sapply(dims, function(d) libtiledb_dim_get_name(d@ptr)) + sch <- schema(arr) + dom <- domain(sch) + dims <- dimensions(dom) + dimnames <- sapply(dims, function(d) libtiledb_dim_get_name(d@ptr)) - idx <- match(name, dimnames) - if (is.na(idx)) stop("Argument '", name, "' not among domain names for array.", call.=FALSE) + idx <- match(name, dimnames) + if (is.na(idx)) stop("Argument '", name, "' not among domain names for array.", call. = FALSE) - tiledb_array_get_non_empty_domain_from_index(arr, idx) + tiledb_array_get_non_empty_domain_from_index(arr, idx) } ## -- matrix return accessors @@ -1879,76 +2035,104 @@ tiledb_array_get_non_empty_domain_from_name <- function(arr, name) { #' @rdname return.matrix-tiledb_array-method #' @param ... Currently unused #' @export -setGeneric("return.matrix", function(object, ...) standardGeneric("return.matrix")) +setGeneric( + "return.matrix", + function(object, ...) standardGeneric("return.matrix") +) #' Retrieve matrix return toggle #' #' A \code{tiledb_array} object can be returned as an array (or list of arrays), -#' or, if select, as a \code{data.frame} or as a \code{matrix}. This methods returns -#' the selection value for the \code{matrix} selection. +#' or, if select, as a \code{data.frame} or as a \code{matrix}. This methods +#' returns the selection value for the \code{matrix} selection. +#' #' @param object A \code{tiledb_array} object #' @return A logical value indicating whether \code{matrix} return is selected #' @export -setMethod("return.matrix", - signature = "tiledb_array", - function(object) object@as.matrix) +setMethod( + "return.matrix", + signature = "tiledb_array", + function(object) object@as.matrix +) #' @rdname return.matrix-set-tiledb_array-method #' @export -setGeneric("return.matrix<-", function(x, value) standardGeneric("return.matrix<-")) +setGeneric( + "return.matrix<-", + function(x, value) standardGeneric("return.matrix<-") +) #' Set matrix return toggle #' #' A \code{tiledb_array} object can be returned as an array (or list of arrays), -#' or, if select, as a \code{data.frame} or a \code{matrix}. This methods sets the -#' selection value for a \code{matrix}. +#' or, if select, as a \code{data.frame} or a \code{matrix}. This methods sets +#' the selection value for a \code{matrix}. +#' #' @param x A \code{tiledb_array} object #' @param value A logical value with the selection #' @return The modified \code{tiledb_array} array object #' @export -setReplaceMethod("return.matrix", - signature = "tiledb_array", - function(x, value) { - x@as.matrix <- value - validObject(x) - x -}) - +setReplaceMethod( + "return.matrix", + signature = "tiledb_array", + function(x, value) { + x@as.matrix <- value + validObject(x) + x + } +) ## -- query_condition accessors #' @rdname query_condition-tiledb_array-method #' @export -setGeneric("query_condition", function(object) standardGeneric("query_condition")) +setGeneric( + "query_condition", + function(object) standardGeneric("query_condition") +) #' @rdname query_condition-set-tiledb_array-method #' @export -setGeneric("query_condition<-", function(x, value) standardGeneric("query_condition<-")) +setGeneric( + "query_condition<-", + function(x, value) standardGeneric("query_condition<-") +) #' Retrieve query_condition value for the array #' #' A \code{tiledb_array} object can have a corresponding query condition object. #' This methods returns it. +#' #' @param object A \code{tiledb_array} object #' @return A \code{tiledb_query_condition} object #' @export -setMethod("query_condition", signature = "tiledb_array", function(object) object@query_condition) +setMethod( + "query_condition", + signature = "tiledb_array", + definition = function(object) object@query_condition +) #' Set query_condition object for the array #' -#' A \code{tiledb_array} object can have an associated query condition object to set -#' conditions on the read queries. This methods sets the \sQuote{query_condition} object. +#' A \code{tiledb_array} object can have an associated query condition object to +#' set conditions on the read queries. This methods sets the +#' \sQuote{query_condition} object. +#' #' @param x A \code{tiledb_array} object #' #' @param value A \code{tiledb_query_conditon_object} #' @return The modified \code{tiledb_array} array object #' @export -setReplaceMethod("query_condition", signature = "tiledb_array", function(x, value) { - stopifnot(`need query_condition object` = is(value, "tiledb_query_condition")) - x@query_condition <- value - validObject(x) - x -}) +setReplaceMethod( + "query_condition", + signature = "tiledb_array", + function(x, value) { + stopifnot(`need query_condition object` = is(value, "tiledb_query_condition")) + x@query_condition <- value + validObject(x) + x + } +) ## -- array return accessors @@ -1960,37 +2144,44 @@ setGeneric("return.array", function(object, ...) standardGeneric("return.array") #' Retrieve array return toggle #' #' A \code{tiledb_array} object can be returned as an array (or list of arrays), -#' or, if select, as a \code{data.frame} or as a \code{matrix}. This methods returns -#' the selection value for the \code{array} selection. +#' or, if select, as a \code{data.frame} or as a \code{matrix}. This methods +#' returns the selection value for the \code{array} selection. +#' #' @param object A \code{tiledb_array} object #' @return A logical value indicating whether \code{array} return is selected #' @export -setMethod("return.array", - signature = "tiledb_array", - function(object) object@as.array) +setMethod( + "return.array", + signature = "tiledb_array", + function(object) object@as.array +) #' @rdname return.array-set-tiledb_array-method #' @export -setGeneric("return.array<-", function(x, value) standardGeneric("return.array<-")) +setGeneric( + "return.array<-", + function(x, value) standardGeneric("return.array<-") +) #' Set array return toggle #' #' A \code{tiledb_array} object can be returned as an array (or list of arrays), -#' or, if select, as a \code{data.frame} or a \code{matrix}. This methods sets the -#' selection value for a \code{array}. +#' or, if select, as a \code{data.frame} or a \code{matrix}. This methods sets +#' the selection value for a \code{array}. +#' #' @param x A \code{tiledb_array} object #' @param value A logical value with the selection #' @return The modified \code{tiledb_array} array object #' @export -setReplaceMethod("return.array", - signature = "tiledb_array", - function(x, value) { - x@as.array <- value - validObject(x) - x -}) - - +setReplaceMethod( + "return.array", + signature = "tiledb_array", + function(x, value) { + x@as.array <- value + validObject(x) + x + } +) ## -- return_as conversion preference @@ -2001,18 +2192,22 @@ setGeneric("return_as", function(object, ...) standardGeneric("return_as")) #' Retrieve return_as conversion preference #' -#' A \code{tiledb_array} object can be returned as a \sQuote{list} (default), \sQuote{array}, -#' \sQuote{matrix}, \sQuote{data.frame}, \sQuote{data.table} or \sQuote{tibble}. This method -#' permits to select a preference for the returned object. The default value of \sQuote{asis} -#' means that no conversion is performed. +#' A \code{tiledb_array} object can be returned as a \sQuote{list} (default), +#' \sQuote{array}, \sQuote{matrix}, \sQuote{data.frame}, \sQuote{data.table} or +#' \sQuote{tibble}. This method permits to select a preference for the returned +#' object. The default value of \sQuote{asis} means that no conversion +#' is performed. +#' #' @param object A \code{tiledb_array} object -#' @return A character value indicating the preferred conversion where the value is -#' one of \sQuote{asis} (the default), \sQuote{array}, \sQuote{matrix},\sQuote{data.frame}, -#' \sQuote{data.table}, or \sQuote{tibble}. +#' @return A character value indicating the preferred conversion where the value +#' is one of \sQuote{asis} (the default), \sQuote{array}, +#' \sQuote{matrix},\sQuote{data.frame}, \sQuote{data.table}, or \sQuote{tibble}. #' @export -setMethod("return_as", - signature = "tiledb_array", - function(object) object@return_as) +setMethod( + "return_as", + signature = "tiledb_array", + function(object) object@return_as +) #' @rdname return_as-set-tiledb_array-method #' @export @@ -2020,104 +2215,132 @@ setGeneric("return_as<-", function(x, value) standardGeneric("return_as<-")) #' Retrieve return_as conversion preference #' -#' A \code{tiledb_array} object can be returned as a \sQuote{list} (default), \sQuote{array}, -#' \sQuote{matrix}, \sQuote{data.frame}, \sQuote{data.table} or \sQuote{tibble}. This method -#' This methods permits to set a preference of returning a \code{list}, \code{array}, -#' \code{matrix}, \code{data.frame}, a \code{data.table}, or a \code{tibble}. The default -#' value of \dQuote{asis} means that no conversion is performed and a \code{list} is returned. +#' A \code{tiledb_array} object can be returned as a \sQuote{list} (default), +#' \sQuote{array}, \sQuote{matrix}, \sQuote{data.frame}, \sQuote{data.table} or +#' \sQuote{tibble}. This method This methods permits to set a preference of +#' returning a \code{list}, \code{array}, \code{matrix}, \code{data.frame}, a +#' \code{data.table}, or a \code{tibble}. The default value of \dQuote{asis} +#' means that no conversion is performed and a \code{list} is returned. +#' #' @param x A \code{tiledb_array} object #' @param value A character value with the selection #' @return The modified \code{tiledb_array} array object #' @export -setReplaceMethod("return_as", - signature = "tiledb_array", - function(x, value) { - x@return_as <- value - validObject(x) - x -}) - +setReplaceMethod( + "return_as", + signature = "tiledb_array", + function(x, value) { + x@return_as <- value + validObject(x) + x + } +) ## -- query_statistics return toggle #' @rdname query_statistics-tiledb_array-method #' @param ... Currently unused #' @export -setGeneric("query_statistics", function(object, ...) standardGeneric("query_statistics")) +setGeneric( + "query_statistics", + function(object, ...) standardGeneric("query_statistics") +) #' Retrieve query_statistics toggle #' -#' A \code{tiledb_array} object can, if requested, return query statistics as a JSON -#' string in an attribute \sQuote{query_statistics} attached to the return object. The -#' default value of the logical switch is \sQuote{FALSE}. This method returns the current -#' value. +#' A \code{tiledb_array} object can, if requested, return query statistics as a +#' JSON string in an attribute \sQuote{query_statistics} attached to the return +#' object. The default value of the logical switch is \sQuote{FALSE}. This +#' method returns the current value. +#' #' @param object A \code{tiledb_array} object #' @return A logical value indicating whether query statistics are returned. #' @export -setMethod("query_statistics", - signature = "tiledb_array", - function(object) object@query_statistics) +setMethod( + "query_statistics", + signature = "tiledb_array", + function(object) object@query_statistics +) #' @rdname query_statistics-set-tiledb_array-method #' @export -setGeneric("query_statistics<-", function(x, value) standardGeneric("query_statistics<-")) +setGeneric( + "query_statistics<-", + function(x, value) standardGeneric("query_statistics<-") +) #' Set query_statistics toggle #' -#' A \code{tiledb_array} object can, if requested, return query statistics as a JSON -#' string in an attribute \sQuote{query_statistics} attached to the return object. The -#' default value of the logical switch is \sQuote{FALSE}. This method sets the value. +#' A \code{tiledb_array} object can, if requested, return query statistics as a +#' JSON string in an attribute \sQuote{query_statistics} attached to the return +#' object. The default value of the logical switch is \sQuote{FALSE}. This +#' method sets the value. +#' #' @param x A \code{tiledb_array} object #' @param value A logical value with the selection #' @return The modified \code{tiledb_array} array object #' @export -setReplaceMethod("query_statistics", - signature = "tiledb_array", - function(x, value) { - x@query_statistics <- value - validObject(x) - x -}) - +setReplaceMethod( + "query_statistics", + signature = "tiledb_array", + function(x, value) { + x@query_statistics <- value + validObject(x) + x + } +) ## -- strings_as_factors getter/setter #' @rdname strings_as_factors-tiledb_array-method #' @export -setGeneric("strings_as_factors", function(object) standardGeneric("strings_as_factors")) +setGeneric( + "strings_as_factors", + function(object) standardGeneric("strings_as_factors") +) #' @rdname strings_as_factors-set-tiledb_array-method #' @export -setGeneric("strings_as_factors<-", function(x, value) standardGeneric("strings_as_factors<-")) +setGeneric( + "strings_as_factors<-", + function(x, value) standardGeneric("strings_as_factors<-") +) #' Retrieve strings_as_factors conversion toggle #' -#' A \code{tiledb_array} object containing character column can have those converted to -#' factors variables. This methods returns the selection value for \sQuote{strings_as_factors}. +#' A \code{tiledb_array} object containing character column can have those +#' converted to factors variables. This methods returns the selection value +#' for \sQuote{strings_as_factors}. +#' #' @param object A \code{tiledb_array} object -#' @return A logical value indicating whether an \code{strings_as_factors} return is selected +#' @return A logical value indicating whether an \code{strings_as_factors} +#' return is selected #' @export -setMethod("strings_as_factors", - signature = "tiledb_array", - function(object) object@strings_as_factors) +setMethod( + "strings_as_factors", + signature = "tiledb_array", + function(object) object@strings_as_factors +) #' Set strings_as_factors return toggle #' -#' A \code{tiledb_array} object containing character column can have those converted to -#' factors variables. This methods sets the selection value for \sQuote{strings_as_factors}. +#' A \code{tiledb_array} object containing character column can have those +#' converted to factors variables. This methods sets the selection value for +#' \sQuote{strings_as_factors}. +#' #' @param x A \code{tiledb_array} object #' @param value A logical value with the selection #' @return The modified \code{tiledb_array} array object #' @export -setReplaceMethod("strings_as_factors", - signature = "tiledb_array", - function(x, value) { - x@strings_as_factors <- value - validObject(x) - x -}) - - +setReplaceMethod( + "strings_as_factors", + signature = "tiledb_array", + function(x, value) { + x@strings_as_factors <- value + validObject(x) + x + } +) ## piped query support @@ -2129,21 +2352,27 @@ setGeneric("tdb_filter", function(x, ...) standardGeneric("tdb_filter")) #' #' @param x A tiledb_array object as first argument, permitting piping #' @param ... One or more expressions that are parsed as query_condition objects -#' @param strict A boolean toogle to, if set, errors if a non-existing attribute is selected -#' or filtered on, defaults to 'TRUE'; if 'FALSE' a warning is shown by execution proceeds. +#' @param strict A boolean toogle to, if set, errors if a non-existing attribute +#' is selected or filtered on, defaults to 'TRUE'; if 'FALSE' a warning is shown +#' by execution proceeds. #' @return The tiledb_array object, permitting piping #' @export -setMethod("tdb_filter", signature("tiledb_array"), function(x, ..., strict=TRUE) { - qc <- parse_query_condition(..., ta=x, debug=FALSE, strict=strict) - if (is.null(qc)) - return(x) - if (isTRUE(x@query_condition@init)) { # if prior qc exists, combine by AND - x@query_condition <- tiledb_query_condition_combine(x@query_condition, qc, "AND") - } else { # else just assign - x@query_condition <- qc +setMethod( + "tdb_filter", + signature("tiledb_array"), + function(x, ..., strict = TRUE) { + qc <- parse_query_condition(..., ta = x, debug = FALSE, strict = strict) + if (is.null(qc)) { + return(x) + } + if (isTRUE(x@query_condition@init)) { # if prior qc exists, combine by AND + x@query_condition <- tiledb_query_condition_combine(x@query_condition, qc, "AND") + } else { # else just assign + x@query_condition <- qc } x -}) + } +) #' @rdname generics #' @export @@ -2156,26 +2385,26 @@ setGeneric("tdb_select", function(x, ...) standardGeneric("tdb_select")) #' @return The tiledb_array object, permitting piping #' @export setMethod("tdb_select", signature("tiledb_array"), function(x, ...) { - if (length(x@sil) == 0) x@sil <- .fill_schema_info_list(x@uri) - ## helper with a nod to data.table and its name_dots - names_from_dots <- function(...) { - dot_sub <- as.list(substitute(list(...)))[-1L] - vnames <- character(length(dot_sub)) - notnamed <- vnames == "" - syms <- sapply(dot_sub, is.symbol) # save the deparse() in most cases of plain symbol - for (i in which(notnamed)) { - tmp <- if (syms[i]) as.character(dot_sub[[i]]) else deparse(dot_sub[[i]])[1L] - if (tmp == make.names(tmp)) vnames[i] <- tmp - } - vnames + if (length(x@sil) == 0) x@sil <- .fill_schema_info_list(x@uri) + ## helper with a nod to data.table and its name_dots + names_from_dots <- function(...) { + dot_sub <- as.list(substitute(list(...)))[-1L] + vnames <- character(length(dot_sub)) + notnamed <- vnames == "" + syms <- sapply(dot_sub, is.symbol) # save the deparse() in most cases of plain symbol + for (i in which(notnamed)) { + tmp <- if (syms[i]) as.character(dot_sub[[i]]) else deparse(dot_sub[[i]])[1L] + if (tmp == make.names(tmp)) vnames[i] <- tmp } + vnames + } - vec <- names_from_dots(...) - ind <- match(vec, x@sil$names) # match against schema names - ind <- ind[x@sil$status[ind] == 2L] # allow only attributes (where status == 2) - newvec <- na.omit(x@sil$names[ ind ]) # and create subset (filtering NA for wrong entry) - x@attrs <- newvec - x + vec <- names_from_dots(...) + ind <- match(vec, x@sil$names) # match against schema names + ind <- ind[x@sil$status[ind] == 2L] # allow only attributes (where status == 2) + newvec <- na.omit(x@sil$names[ind]) # and create subset (filtering NA for wrong entry) + x@attrs <- newvec + x }) #' @rdname generics @@ -2186,23 +2415,25 @@ setGeneric("tdb_collect", function(x, ...) standardGeneric("tdb_collect")) #' #' @param x A tiledb_array object as first argument, permitting piping #' @param ... Ignored -#' @return The object returning from a tiledb_array query (the type of which can be -#' set via the return preference mechanism, see the help for \code{"["} accessor) +#' @return The object returning from a tiledb_array query (the type of which +#' can be set via the return preference mechanism, see the help for +#' \code{"["} accessor) #' @export setMethod("tdb_collect", signature("tiledb_array"), function(x, ...) { - x[] + x[] }) # unexported helper .fill_schema_info_list <- function(ta) { - sch <- schema(ta) - list(names=tiledb_schema_get_names(sch), - types=tiledb_schema_get_types(sch), - status=tiledb_schema_get_dim_attr_status(sch), - enum=tiledb_schema_get_enumeration_status(sch)) + sch <- schema(ta) + list( + names = tiledb_schema_get_names(sch), + types = tiledb_schema_get_types(sch), + status = tiledb_schema_get_dim_attr_status(sch), + enum = tiledb_schema_get_enumeration_status(sch) + ) } - ## Entry points for tiledb_dense and tiledb_sparse #' @rdname tiledb_array @@ -2210,21 +2441,25 @@ setMethod("tdb_collect", signature("tiledb_array"), function(x, ...) { #' and \code{tiledb_sparse} aliasing #' @export tiledb_dense <- function(...) { - if (isFALSE("tiledb_dense_called" %in% names(.pkgenv))) { - message("The 'tiledb_dense' function has been removed following a long deprecation. ", - "This call will be forwarded to 'tiledb_array(..., is.sparse=FALSE)'.") - .pkgenv[["tiledb_dense_called"]] <- TRUE # ensure we nag only once per session - } - tiledb_array(..., is.sparse = FALSE) + if (isFALSE("tiledb_dense_called" %in% names(.pkgenv))) { + message( + "The 'tiledb_dense' function has been removed following a long deprecation. ", + "This call will be forwarded to 'tiledb_array(..., is.sparse=FALSE)'." + ) + .pkgenv[["tiledb_dense_called"]] <- TRUE # ensure we nag only once per session + } + tiledb_array(..., is.sparse = FALSE) } #' @rdname tiledb_array #' @export tiledb_sparse <- function(...) { - if (isFALSE("tiledb_sparse_called" %in% names(.pkgenv))) { - message("The 'tiledb_sparse' function has been removed following a long deprecation. ", - "This call will be forwarded to 'tiledb_array(..., is.sparse=TRUE)'.") - .pkgenv[["tiledb_sparse_called"]] <- TRUE # ensure we nag only once per session - } - tiledb_array(..., is.sparse = TRUE) + if (isFALSE("tiledb_sparse_called" %in% names(.pkgenv))) { + message( + "The 'tiledb_sparse' function has been removed following a long deprecation. ", + "This call will be forwarded to 'tiledb_array(..., is.sparse=TRUE)'." + ) + .pkgenv[["tiledb_sparse_called"]] <- TRUE # ensure we nag only once per session + } + tiledb_array(..., is.sparse = TRUE) } diff --git a/R/Utils.R b/R/Utils.R index 262b29e54e..c8dff9ebfc 100644 --- a/R/Utils.R +++ b/R/Utils.R @@ -22,54 +22,68 @@ packageName <- function() "tiledb" -##' Save (or load) \sQuote{return_as} conversion preference in an optional config file +##' Save (or load) \sQuote{return_as} conversion preference in an +##' optional config file ##' -##' The \code{tiledb_array} object can set a preference for conversion for each retrieved -##' object. This preference can also be enconded in a configuration file as R (version -##' 4.0.0 or later) allows a user- and package specific configuration files. These helper -##' functions sets and retrieve the value, respectively, or retrieve the cached value from -##' the package environment where is it set at package load. +##' The \code{tiledb_array} object can set a preference for conversion for each +##' retrieved object. This preference can also be encoded in a configuration +##' file as R (version 4.0.0 or later) allows a user- and package specific +##' configuration files. These helper functions set and retrieve the value, +##' respectively, or retrieve the cached value from the package environment where +##' it is set at package load. ##' -##' Note that the value must be one of \sQuote{asis} (the default), \sQuote{array}, -##' \sQuote{matrix}\sQuote{data.frame}, \sQuote{data.table} or \sQuote{tibble}. The latter -##' two require the corresponding package to be installed. +##' Note that the value must be one of \sQuote{asis} (the default), +##' \sQuote{array}, \sQuote{matrix}\sQuote{data.frame}, \sQuote{data.table} or +##' \sQuote{tibble}. The latter two require the corresponding package to +##' be installed. ##' ##' @note This function requires R version 4.0.0 or later to utilise the per-user -##' config directory accessor function. For older R versions, please set the attribute -##' directly when creating the \code{tiledb_array} object, or via the +##' config directory accessor function. For older R versions, please set the +##' attribute directly when creating the \code{tiledb_array} object, or via the ##' \code{return_as()} method. +##' ##' @title Store object conversion preference ##' @param value A character variable with one of the six permitted values -##' @return For the setter, \code{TRUE} is returned invisibly but the function is invoked for the -##' side effect of storing the value. For either getter, the character value. +##' @return For the setter, \code{TRUE} is returned invisibly but the function +##' is invoked for the side effect of storing the value. For either getter, +##' the character value. ##' @export -save_return_as_preference <- function(value = c("asis", "array", "matrix", "data.frame", - "data.table", "tibble")) { - stopifnot(`This function relies on R version 4.0.0 or later.` = R.version.string >= "4.0.0") - value <- match.arg(value) - - cfgdir <- tools::R_user_dir(packageName()) - if (!dir.exists(cfgdir)) dir.create(cfgdir, recursive = TRUE) - fname <- file.path(cfgdir, "config.dcf") - con <- file(fname, "a+") - cat("return_as:", value, "\n", file=con) - close(con) - set_return_as_preference(value) - invisible(TRUE) +save_return_as_preference <- function( + value = c( + "asis", + "array", + "matrix", + "data.frame", + "data.table", + "tibble" + ) +) { + stopifnot(`This function relies on R version 4.0.0 or later.` = R.version.string >= "4.0.0") + value <- match.arg(value) + + cfgdir <- tools::R_user_dir(packageName()) + if (!dir.exists(cfgdir)) dir.create(cfgdir, recursive = TRUE) + fname <- file.path(cfgdir, "config.dcf") + con <- file(fname, "a+") + cat("return_as:", value, "\n", file = con) + close(con) + set_return_as_preference(value) + invisible(TRUE) } ##' @rdname save_return_as_preference ##' @export load_return_as_preference <- function() { - value <- "asis" # default, and fallback - cfgfile <- .defaultConfigFile() - if (cfgfile != "" && file.exists(cfgfile)) { - cfg <- read.dcf(cfgfile) - if ("return_as" %in% colnames(cfg)) - value <- cfg[[1, "return_as"]] + value <- "asis" # default, and fallback + cfgfile <- .defaultConfigFile() + if (cfgfile != "" && file.exists(cfgfile)) { + cfg <- read.dcf(cfgfile) + if ("return_as" %in% colnames(cfg)) { + value <- cfg[[1, "return_as"]] } - set_return_as_preference(value) - value + } + set_return_as_preference(value) + value } ##' @rdname save_return_as_preference @@ -78,13 +92,20 @@ get_return_as_preference <- function() .pkgenv[["return_as"]] ##' @rdname save_return_as_preference ##' @export -set_return_as_preference <- function(value = c("asis", "array", "matrix", "data.frame", - "data.table", "tibble")) { - value <- match.arg(value) - .pkgenv[["return_as"]] <- value +set_return_as_preference <- function( + value = c( + "asis", + "array", + "matrix", + "data.frame", + "data.table", + "tibble" + ) +) { + value <- match.arg(value) + .pkgenv[["return_as"]] <- value } - ##' Save (or load) allocation size default preference in an optional ##' config file ##' @@ -116,35 +137,39 @@ set_return_as_preference <- function(value = c("asis", "array", "matrix", "data. ##' TileDB configuration object is used. ##' @title Store allocation size preference ##' @param value A numeric value with the desired allocation size (in bytes). -##' @return For the setter, \code{TRUE} is returned invisibly but the function is invoked for the -##' side effect of storing the value. For the getters, the value as a numeric. +##' @return For the setter, \code{TRUE} is returned invisibly but the function is +##' invoked for the side effect of storing the value. For the getters, the +##' value as a numeric. ##' @export save_allocation_size_preference <- function(value) { - stopifnot(`This function relies on R version 4.0.0 or later.` = R.version.string >= "4.0.0", - `The 'value' has to be numeric` = is.numeric(value)) - - cfgdir <- tools::R_user_dir(packageName()) - if (!dir.exists(cfgdir)) dir.create(cfgdir, recursive = TRUE) - fname <- file.path(cfgdir, "config.dcf") - con <- file(fname, "a+") - cat("allocation_size:", value, "\n", file=con) - close(con) - set_allocation_size_preference(value) - invisible(TRUE) + stopifnot( + `This function relies on R version 4.0.0 or later.` = R.version.string >= "4.0.0", + `The 'value' has to be numeric` = is.numeric(value) + ) + + cfgdir <- tools::R_user_dir(packageName()) + if (!dir.exists(cfgdir)) dir.create(cfgdir, recursive = TRUE) + fname <- file.path(cfgdir, "config.dcf") + con <- file(fname, "a+") + cat("allocation_size:", value, "\n", file = con) + close(con) + set_allocation_size_preference(value) + invisible(TRUE) } ##' @rdname save_allocation_size_preference ##' @export load_allocation_size_preference <- function() { - value <- 10 * 1024 * 1024 # fallback value is 10mb - cfgfile <- .defaultConfigFile() # but check config file - if (cfgfile != "" && file.exists(cfgfile)) { - cfg <- read.dcf(cfgfile) - if ("allocation_size" %in% colnames(cfg)) - value <- as.numeric(cfg[[1, "allocation_size"]]) + value <- 10 * 1024 * 1024 # fallback value is 10mb + cfgfile <- .defaultConfigFile() # but check config file + if (cfgfile != "" && file.exists(cfgfile)) { + cfg <- read.dcf(cfgfile) + if ("allocation_size" %in% colnames(cfg)) { + value <- as.numeric(cfg[[1, "allocation_size"]]) } - set_allocation_size_preference(value) - value + } + set_allocation_size_preference(value) + value } ##' @rdname save_allocation_size_preference @@ -154,42 +179,46 @@ get_allocation_size_preference <- function() .pkgenv[["allocation_size"]] ##' @rdname save_allocation_size_preference ##' @export set_allocation_size_preference <- function(value) { - stopifnot(`The 'value' has to be numeric` = is.numeric(value)) - .pkgenv[["allocation_size"]] <- value + stopifnot(`The 'value' has to be numeric` = is.numeric(value)) + .pkgenv[["allocation_size"]] <- value } - - - is.scalar <- function(x, typestr) { - (typeof(x) == typestr) && is.atomic(x) && length(x) == 1L + (typeof(x) == typestr) && is.atomic(x) && length(x) == 1L } ## Adapted from the DelayedArray package ##' @importFrom utils tail nd_index_from_syscall <- function(call, env_frame) { - index <- lapply(seq_len(length(call) - 2L), - function(idx){ - subscript <- call[[2L + idx]] - if (missing(subscript)) - return(NULL) - subscript <- eval(subscript, envir = env_frame, enclos = env_frame) - return(subscript) - }) + index <- lapply( + seq_len(length(call) - 2L), + function(idx) { + subscript <- call[[2L + idx]] + if (missing(subscript)) { + return(NULL) + } + subscript <- eval(subscript, envir = env_frame, enclos = env_frame) + return(subscript) + } + ) argnames <- tail(names(call), n = -2L) - if (!is.null(argnames)) + if (!is.null(argnames)) { index <- index[!(argnames %in% c("drop", "exact", "value"))] - if (length(index) == 1L && is.null(index[[1L]])) + } + if (length(index) == 1L && is.null(index[[1L]])) { index <- list() + } return(index) } isNestedList <- function(l) { - stopifnot(`Argument 'l' must be a list` = is.list(l)) - for (i in l) { - if (is.list(i)) return(TRUE) + stopifnot(`Argument 'l' must be a list` = is.list(l)) + for (i in l) { + if (is.list(i)) { + return(TRUE) } - return(FALSE) + } + return(FALSE) } ##' Look up TileDB type corresponding to the type of an R object @@ -199,101 +228,109 @@ isNestedList <- function(l) { ##' @return single character, e.g. INT32 ##' @export r_to_tiledb_type <- function(x) { - storage_mode <- storage.mode(x) - if (storage_mode == "list") - storage_mode <- storage.mode(x[[1]]) - if (storage_mode == "integer" || storage_mode == "logical") { - type <- "INT32" - } else if (storage_mode == "double"){ - type <- "FLOAT64" - } else if (storage_mode == "character"){ - type <- "UTF8" - } else { - message("Data type ", storage_mode, " not supported for now.") - } - type + storage_mode <- storage.mode(x) + if (storage_mode == "list") { + storage_mode <- storage.mode(x[[1]]) + } + if (storage_mode == "integer" || storage_mode == "logical") { + type <- "INT32" + } else if (storage_mode == "double") { + type <- "FLOAT64" + } else if (storage_mode == "character") { + type <- "UTF8" + } else { + message("Data type ", storage_mode, " not supported for now.") + } + type } ## next two were in file MetaData.R .isArray <- function(arr) { - is(arr, "tiledb_sparse") || is(arr, "tiledb_dense") || is(arr, "tiledb_array") + is(arr, "tiledb_sparse") || is(arr, "tiledb_dense") || is(arr, "tiledb_array") } .assertArray <- function(arr) { - stopifnot(is(arr, "tiledb_sparse") || is(arr, "tiledb_dense") || is(arr, "tiledb_array")) + stopifnot(is(arr, "tiledb_sparse") || is(arr, "tiledb_dense") || is(arr, "tiledb_array")) } ## conversion helper from (and to) legacy validity map for nullable strings -.legacy_validity <- function(inuri, - outdir = NULL, - fromlegacy = TRUE, - tolegacy = FALSE, - usetmp = FALSE, - verbose = FALSE, - debug = FALSE) { - - stopifnot("'inuri' must be an existing directory" = dir.exists(inuri)) - - if (verbose) - cat("Running with tiledb R package version", format(packageVersion("tiledb")), - "and TileDB Core version", format(tiledb_version(TRUE)), "\n") - - array <- basename(inuri) - if (debug) print(summary(tiledb_array(inuri, strings_as_factors=TRUE)[])) - - newdir <- "" - if (isTRUE(usetmp)) newdir <- tempfile() - if (!is.null(outdir)) newdir <- outdir - if (newdir == "") - stop("If '--usetmp' is not given then '--out OUT' must be given.", call. = FALSE) - - if (!dir.exists(newdir)) dir.create(newdir) - #res <- file.copy(inuri, newdir, recursive=TRUE) - newuri <- file.path(newdir, array) - - arr <- tiledb_array(inuri) - attrlst <- attrs(schema(arr)) - is_nullable_string <- function(x) datatype(x) %in% c("ASCII", "CHAR", "UTF8") && - tiledb_attribute_get_nullable(x) - stringcols <- Filter(is_nullable_string, attrlst) - if (length(stringcols) == 0) { - stop("No string columns in array so nothing to do. Exiting.\n", call. = FALSE) - } - dimnames <- sapply(dimensions(domain(schema(arr))), name) - - oldcfg <- cfg <- tiledb_config() - cfg["r.legacy_validity_mode"] <- if (fromlegacy) "true" else "false" - ctx <- tiledb_ctx(cfg) - dat <- tiledb_array(inuri, return_as="data.frame", strings_as_factors=TRUE)[] - if (debug) print(summary(dat)) - - arr <- tiledb_array(inuri) - arr <- tiledb_array_open(arr, "READ") - nmd <- tiledb_num_metadata(arr) - if (nmd > 0) metadatalist <- tiledb_get_all_metadata(arr) - if (debug) print(metadatalist) - - cfg["r.legacy_validity_mode"] <- if (tolegacy) "true" else "false" - ctx <- tiledb_ctx(cfg) - fromDataFrame(dat, newuri, col_index=dimnames) - - if (nmd > 0) { - arr <- tiledb_array(newuri) - arr <- tiledb_array_open(arr, "WRITE") - for (nm in names(metadatalist)) { - invisible(tiledb_put_metadata(arr, nm, metadatalist[[nm]])) - if (debug) print(metadatalist[[nm]]) - } - invisible(tiledb_array_close(arr)) - } - - chk <- tiledb_array(newuri, strings_as_factors=TRUE)[] - if (debug) { - cat("Written back.\n") - print(summary(chk)) +.legacy_validity <- function( + inuri, + outdir = NULL, + fromlegacy = TRUE, + tolegacy = FALSE, + usetmp = FALSE, + verbose = FALSE, + debug = FALSE +) { + stopifnot("'inuri' must be an existing directory" = dir.exists(inuri)) + + if (verbose) { + cat( + "Running with tiledb R package version", format(packageVersion("tiledb")), + "and TileDB Core version", format(tiledb_version(TRUE)), "\n" + ) + } + + array <- basename(inuri) + if (debug) print(summary(tiledb_array(inuri, strings_as_factors = TRUE)[])) + + newdir <- "" + if (isTRUE(usetmp)) newdir <- tempfile() + if (!is.null(outdir)) newdir <- outdir + if (newdir == "") { + stop("If '--usetmp' is not given then '--out OUT' must be given.", call. = FALSE) + } + + if (!dir.exists(newdir)) dir.create(newdir) + # res <- file.copy(inuri, newdir, recursive=TRUE) + newuri <- file.path(newdir, array) + + arr <- tiledb_array(inuri) + attrlst <- attrs(schema(arr)) + is_nullable_string <- function(x) { + datatype(x) %in% c("ASCII", "CHAR", "UTF8") && + tiledb_attribute_get_nullable(x) + } + stringcols <- Filter(is_nullable_string, attrlst) + if (length(stringcols) == 0) { + stop("No string columns in array so nothing to do. Exiting.\n", call. = FALSE) + } + dimnames <- sapply(dimensions(domain(schema(arr))), name) + + oldcfg <- cfg <- tiledb_config() + cfg["r.legacy_validity_mode"] <- if (fromlegacy) "true" else "false" + ctx <- tiledb_ctx(cfg) + dat <- tiledb_array(inuri, return_as = "data.frame", strings_as_factors = TRUE)[] + if (debug) print(summary(dat)) + + arr <- tiledb_array(inuri) + arr <- tiledb_array_open(arr, "READ") + nmd <- tiledb_num_metadata(arr) + if (nmd > 0) metadatalist <- tiledb_get_all_metadata(arr) + if (debug) print(metadatalist) + + cfg["r.legacy_validity_mode"] <- if (tolegacy) "true" else "false" + ctx <- tiledb_ctx(cfg) + fromDataFrame(dat, newuri, col_index = dimnames) + + if (nmd > 0) { + arr <- tiledb_array(newuri) + arr <- tiledb_array_open(arr, "WRITE") + for (nm in names(metadatalist)) { + invisible(tiledb_put_metadata(arr, nm, metadatalist[[nm]])) + if (debug) print(metadatalist[[nm]]) } - if (verbose) cat("Done.\n") - ctx <- tiledb_ctx(oldcfg) # reset - invisible() + invisible(tiledb_array_close(arr)) + } + + chk <- tiledb_array(newuri, strings_as_factors = TRUE)[] + if (debug) { + cat("Written back.\n") + print(summary(chk)) + } + if (verbose) cat("Done.\n") + ctx <- tiledb_ctx(oldcfg) # reset + invisible() } diff --git a/R/VFS.R b/R/VFS.R index f045035dd0..fa32bf17f5 100644 --- a/R/VFS.R +++ b/R/VFS.R @@ -24,8 +24,10 @@ #' #' @slot ptr An external pointer to the underlying implementation #' @exportClass tiledb_vfs -setClass("tiledb_vfs", - slots = list(ptr = "externalptr")) +setClass( + "tiledb_vfs", + slots = list(ptr = "externalptr") +) #' Creates a `tiledb_vfs` object #' @@ -33,13 +35,14 @@ setClass("tiledb_vfs", #' @param ctx (optional) A TileDB Ctx object #' @return The `tiledb_vfs` object #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' # default configuration #' vfs <- tiledb_vfs() #' #' @export tiledb_vfs <- function(config = NULL, ctx = tiledb_get_context()) { - ## otherwise create a new ctx and cache it if (is.null(config)) { ptr <- libtiledb_vfs(ctx@ptr) @@ -63,8 +66,10 @@ tiledb_vfs <- function(config = NULL, ctx = tiledb_get_context()) { #' @return The uri value #' @export tiledb_vfs_create_bucket <- function(uri, vfs = tiledb_get_vfs()) { - stopifnot(`Argument 'vfs' must be a tiledb_vfs object` = is(vfs, "tiledb_vfs"), - `Argument 'uri' must be character` = is.character(uri)) + stopifnot( + `Argument 'vfs' must be a tiledb_vfs object` = is(vfs, "tiledb_vfs"), + `Argument 'uri' must be character` = is.character(uri) + ) libtiledb_vfs_create_bucket(vfs@ptr, uri) } @@ -75,8 +80,10 @@ tiledb_vfs_create_bucket <- function(uri, vfs = tiledb_get_vfs()) { #' @return The uri value #' @export tiledb_vfs_remove_bucket <- function(uri, vfs = tiledb_get_vfs()) { - stopifnot(`Argument 'vfs' must be a tiledb_vfs object` = is(vfs, "tiledb_vfs"), - `Argument 'uri' must be character` = is.character(uri)) + stopifnot( + `Argument 'vfs' must be a tiledb_vfs object` = is(vfs, "tiledb_vfs"), + `Argument 'uri' must be character` = is.character(uri) + ) libtiledb_vfs_remove_bucket(vfs@ptr, uri) } @@ -87,7 +94,9 @@ tiledb_vfs_remove_bucket <- function(uri, vfs = tiledb_get_vfs()) { #' @return A boolean value indicating if it is a valid bucket #' @export #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' \dontrun{ #' cfg <- tiledb_config() #' cfg["vfs.s3.region"] <- "us-west-1" @@ -96,8 +105,10 @@ tiledb_vfs_remove_bucket <- function(uri, vfs = tiledb_get_vfs()) { #' tiledb_vfs_is_bucket(vfs, "s3://tiledb-public-us-west-1/test-array-4x4") #' } tiledb_vfs_is_bucket <- function(uri, vfs = tiledb_get_vfs()) { - stopifnot(`Argument 'vfs' must be a tiledb_vfs object` = is(vfs, "tiledb_vfs"), - `Argument 'uri' must be character` = is.character(uri)) + stopifnot( + `Argument 'vfs' must be a tiledb_vfs object` = is(vfs, "tiledb_vfs"), + `Argument 'uri' must be character` = is.character(uri) + ) libtiledb_vfs_is_bucket(vfs@ptr, uri) } @@ -108,7 +119,9 @@ tiledb_vfs_is_bucket <- function(uri, vfs = tiledb_get_vfs()) { #' @return A boolean value indicating if it is an empty bucket #' @export #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' \dontrun{ #' cfg <- tiledb_config() #' cfg["vfs.s3.region"] <- "us-west-1" @@ -117,8 +130,10 @@ tiledb_vfs_is_bucket <- function(uri, vfs = tiledb_get_vfs()) { #' tiledb_vfs_is_empty_bucket(vfs, "s3://tiledb-public-us-west-1/test-array-4x4") #' } tiledb_vfs_is_empty_bucket <- function(uri, vfs = tiledb_get_vfs()) { - stopifnot(`Argument 'vfs' must be a tiledb_vfs object` = is(vfs, "tiledb_vfs"), - `Argument 'uri' must be character` = is.character(uri)) + stopifnot( + `Argument 'vfs' must be a tiledb_vfs object` = is(vfs, "tiledb_vfs"), + `Argument 'uri' must be character` = is.character(uri) + ) libtiledb_vfs_is_empty_bucket(vfs@ptr, uri) } @@ -129,8 +144,10 @@ tiledb_vfs_is_empty_bucket <- function(uri, vfs = tiledb_get_vfs()) { #' @return The URI value that was emptied #' @export tiledb_vfs_empty_bucket <- function(uri, vfs = tiledb_get_vfs()) { - stopifnot(`Argument 'vfs' must be a tiledb_vfs object` = is(vfs, "tiledb_vfs"), - `Argument 'uri' must be character` = is.character(uri)) + stopifnot( + `Argument 'vfs' must be a tiledb_vfs object` = is(vfs, "tiledb_vfs"), + `Argument 'uri' must be character` = is.character(uri) + ) libtiledb_vfs_empty_bucket(vfs@ptr, uri) } @@ -141,8 +158,10 @@ tiledb_vfs_empty_bucket <- function(uri, vfs = tiledb_get_vfs()) { #' @return The uri value of the created directory #' @export tiledb_vfs_create_dir <- function(uri, vfs = tiledb_get_vfs()) { - stopifnot(`Argument 'vfs' must be a tiledb_vfs object` = is(vfs, "tiledb_vfs"), - `Argument 'uri' must be character` = is.character(uri)) + stopifnot( + `Argument 'vfs' must be a tiledb_vfs object` = is(vfs, "tiledb_vfs"), + `Argument 'uri' must be character` = is.character(uri) + ) libtiledb_vfs_create_dir(vfs@ptr, uri) } @@ -153,8 +172,10 @@ tiledb_vfs_create_dir <- function(uri, vfs = tiledb_get_vfs()) { #' @return A boolean value indicating if it is a directory #' @export tiledb_vfs_is_dir <- function(uri, vfs = tiledb_get_vfs()) { - stopifnot(`Argument 'vfs' must be a tiledb_vfs object` = is(vfs, "tiledb_vfs"), - `Argument 'uri' must be character` = is.character(uri)) + stopifnot( + `Argument 'vfs' must be a tiledb_vfs object` = is(vfs, "tiledb_vfs"), + `Argument 'uri' must be character` = is.character(uri) + ) libtiledb_vfs_is_dir(vfs@ptr, uri) } @@ -165,8 +186,10 @@ tiledb_vfs_is_dir <- function(uri, vfs = tiledb_get_vfs()) { #' @return The uri value of the removed directory #' @export tiledb_vfs_remove_dir <- function(uri, vfs = tiledb_get_vfs()) { - stopifnot(`Argument 'vfs' must be a tiledb_vfs object` = is(vfs, "tiledb_vfs"), - `Argument 'uri' must be character` = is.character(uri)) + stopifnot( + `Argument 'vfs' must be a tiledb_vfs object` = is(vfs, "tiledb_vfs"), + `Argument 'uri' must be character` = is.character(uri) + ) invisible(libtiledb_vfs_remove_dir(vfs@ptr, uri)) } @@ -177,8 +200,10 @@ tiledb_vfs_remove_dir <- function(uri, vfs = tiledb_get_vfs()) { #' @return A boolean value indicating if it is a file #' @export tiledb_vfs_is_file <- function(uri, vfs = tiledb_get_vfs()) { - stopifnot(`Argument 'vfs' must be a tiledb_vfs object` = is(vfs, "tiledb_vfs"), - `Argument 'uri' must be character` = is.character(uri)) + stopifnot( + `Argument 'vfs' must be a tiledb_vfs object` = is(vfs, "tiledb_vfs"), + `Argument 'uri' must be character` = is.character(uri) + ) libtiledb_vfs_is_file(vfs@ptr, uri) } @@ -189,8 +214,10 @@ tiledb_vfs_is_file <- function(uri, vfs = tiledb_get_vfs()) { #' @return The uri value of the removed file #' @export tiledb_vfs_remove_file <- function(uri, vfs = tiledb_get_vfs()) { - stopifnot(`Argument 'vfs' must be a tiledb_vfs object` = is(vfs, "tiledb_vfs"), - `Argument 'uri' must be character` = is.character(uri)) + stopifnot( + `Argument 'vfs' must be a tiledb_vfs object` = is(vfs, "tiledb_vfs"), + `Argument 'uri' must be character` = is.character(uri) + ) libtiledb_vfs_remove_file(vfs@ptr, uri) } @@ -201,8 +228,10 @@ tiledb_vfs_remove_file <- function(uri, vfs = tiledb_get_vfs()) { #' @return The size of the file #' @export tiledb_vfs_file_size <- function(uri, vfs = tiledb_get_vfs()) { - stopifnot(`Argument 'vfs' must be a tiledb_vfs object` = is(vfs, "tiledb_vfs"), - `Argument 'uri' must be character` = is.character(uri)) + stopifnot( + `Argument 'vfs' must be a tiledb_vfs object` = is(vfs, "tiledb_vfs"), + `Argument 'uri' must be character` = is.character(uri) + ) libtiledb_vfs_file_size(vfs@ptr, uri) } @@ -214,9 +243,11 @@ tiledb_vfs_file_size <- function(uri, vfs = tiledb_get_vfs()) { #' @return The newuri value of the moved file #' @export tiledb_vfs_move_file <- function(olduri, newuri, vfs = tiledb_get_vfs()) { - stopifnot(`Argument 'vfs' must be a tiledb_vfs object` = is(vfs, "tiledb_vfs"), - `Argument 'olduri' must be character` = is.character(olduri), - `Argument 'newuri' must be character` = is.character(newuri)) + stopifnot( + `Argument 'vfs' must be a tiledb_vfs object` = is(vfs, "tiledb_vfs"), + `Argument 'olduri' must be character` = is.character(olduri), + `Argument 'newuri' must be character` = is.character(newuri) + ) libtiledb_vfs_move_file(vfs@ptr, olduri, newuri) } @@ -228,9 +259,11 @@ tiledb_vfs_move_file <- function(olduri, newuri, vfs = tiledb_get_vfs()) { #' @return The newuri value of the moved directory #' @export tiledb_vfs_move_dir <- function(olduri, newuri, vfs = tiledb_get_vfs()) { - stopifnot(`Argument 'vfs' must be a tiledb_vfs object` = is(vfs, "tiledb_vfs"), - `Argument 'olduri' must be character` = is.character(olduri), - `Argument 'newuri' must be character` = is.character(newuri)) + stopifnot( + `Argument 'vfs' must be a tiledb_vfs object` = is(vfs, "tiledb_vfs"), + `Argument 'olduri' must be character` = is.character(olduri), + `Argument 'newuri' must be character` = is.character(newuri) + ) libtiledb_vfs_move_dir(vfs@ptr, olduri, newuri) } @@ -241,8 +274,10 @@ tiledb_vfs_move_dir <- function(olduri, newuri, vfs = tiledb_get_vfs()) { #' @return The uri value #' @export tiledb_vfs_touch <- function(uri, vfs = tiledb_get_vfs()) { - stopifnot(`Argument 'vfs' must be a tiledb_vfs object` = is(vfs, "tiledb_vfs"), - `Argument 'uri' must be character` = is.character(uri)) + stopifnot( + `Argument 'vfs' must be a tiledb_vfs object` = is(vfs, "tiledb_vfs"), + `Argument 'uri' must be character` = is.character(uri) + ) libtiledb_vfs_touch(vfs@ptr, uri) } @@ -284,80 +319,100 @@ tiledb_set_vfs <- function(vfs) { #' @param ctx (optional) A TileDB Ctx object #' @return A TileDB VFS Filehandle object (as an external pointer) #' @export -tiledb_vfs_open <- function(binfile, mode = c("READ", "WRITE", "APPEND"), - vfs = tiledb_get_vfs(), ctx = tiledb_get_context()) { +tiledb_vfs_open <- function( + binfile, + mode = c("READ", "WRITE", "APPEND"), + vfs = tiledb_get_vfs(), + ctx = tiledb_get_context() +) { mode <- match.arg(mode) - stopifnot(`Argument 'vfs' must be a tiledb_vfs object` = is(vfs, "tiledb_vfs"), - `Argument 'ctx' must be a tiledb_ctx object` = is(ctx, "tiledb_ctx"), - `Argument 'binfile' must be character` = is.character(binfile)) + stopifnot( + `Argument 'vfs' must be a tiledb_vfs object` = is(vfs, "tiledb_vfs"), + `Argument 'ctx' must be a tiledb_ctx object` = is(ctx, "tiledb_ctx"), + `Argument 'binfile' must be character` = is.character(binfile) + ) libtiledb_vfs_open(ctx@ptr, vfs@ptr, binfile, mode) } #' Close a TileDB VFS Filehandle #' -#' @param fh A TileDB VFS Filehandle external pointer as returned from \code{tiledb_vfs_open} +#' @param fh A TileDB VFS Filehandle external pointer as returned from +#' \code{tiledb_vfs_open} #' @param ctx (optional) A TileDB Ctx object #' @return The result of the close operation is returned. #' @export tiledb_vfs_close <- function(fh, ctx = tiledb_get_context()) { - stopifnot(`Argument 'fh' must be an external pointer` = is(fh, "externalptr"), - `Argument 'ctx' must be a tiledb_ctx object` = is(ctx, "tiledb_ctx")) + stopifnot( + `Argument 'fh' must be an external pointer` = is(fh, "externalptr"), + `Argument 'ctx' must be a tiledb_ctx object` = is(ctx, "tiledb_ctx") + ) libtiledb_vfs_close(ctx@ptr, fh) } #' Sync a TileDB VFS Filehandle #' -#' @param fh A TileDB VFS Filehandle external pointer as returned from \code{tiledb_vfs_open} +#' @param fh A TileDB VFS Filehandle external pointer as returned from +#' \code{tiledb_vfs_open} #' @param ctx (optional) A TileDB Ctx object #' @return The result of the sync operation is returned. #' @export tiledb_vfs_sync <- function(fh, ctx = tiledb_get_context()) { - stopifnot(`Argument 'fh' must be an external pointer` = is(fh, "externalptr"), - `Argument 'ctx' must be a tiledb_ctx object` = is(ctx, "tiledb_ctx")) + stopifnot( + `Argument 'fh' must be an external pointer` = is(fh, "externalptr"), + `Argument 'ctx' must be a tiledb_ctx object` = is(ctx, "tiledb_ctx") + ) libtiledb_vfs_sync(ctx@ptr, fh) } #' Write to a TileDB VFS Filehandle #' -#' This interface currently defaults to using an integer vector. This is suitable for R objects -#' as the raw vector result from serialization can be mapped easily to an integer vector. It is -#' also possible to \code{memcpy} to the contiguous memory of an integer vector should other -#' (non-R) data be transferred. -#' @param fh A TileDB VFS Filehandle external pointer as returned from \code{tiledb_vfs_open} +#' This interface currently defaults to using an integer vector. This is suitable +#' for R objects as the raw vector result from serialization can be mapped easily +#' to an integer vector. It is also possible to \code{memcpy} to the contiguous +#' memory of an integer vector should other (non-R) data be transferred. +#' +#' @param fh A TileDB VFS Filehandle external pointer as returned from +#' \code{tiledb_vfs_open} #' @param vec An integer vector of content to be written #' @param ctx (optional) A TileDB Ctx object #' @return The result of the write operation is returned. #' @export tiledb_vfs_write <- function(fh, vec, ctx = tiledb_get_context()) { - stopifnot(`Argument 'fh' must be an external pointer` = is(fh, "externalptr"), - `Argument 'vec' must be integer` = is.integer(vec), - `Argument 'ctx' must be a tiledb_ctx object` = is(ctx, "tiledb_ctx")) + stopifnot( + `Argument 'fh' must be an external pointer` = is(fh, "externalptr"), + `Argument 'vec' must be integer` = is.integer(vec), + `Argument 'ctx' must be a tiledb_ctx object` = is(ctx, "tiledb_ctx") + ) libtiledb_vfs_write(ctx@ptr, fh, vec) } #' Read from a TileDB VFS Filehandle #' -#' This interface currently defaults to reading an integer vector. This is suitable for R objects -#' as a raw vector used for (de)serialization can be mapped easily to an integer vector. It is -#' also possible to \code{memcpy} to the contiguous memory of an integer vector should other -#' (non-R) data be transferred. -#' @param fh A TileDB VFS Filehandle external pointer as returned from \code{tiledb_vfs_open} -#' @param offset A scalar value with the byte offset from the beginning of the file -#' with a of zero. +#' This interface currently defaults to reading an integer vector. This is +#' suitable for R objects as a raw vector used for (de)serialization can be +#' mapped easily to an integer vector. It is also possible to \code{memcpy} to +#' the contiguous memory of an integer vector should other (non-R) data +#' be transferred. +#' @param fh A TileDB VFS Filehandle external pointer as returned from +#' \code{tiledb_vfs_open} +#' @param offset A scalar value with the byte offset from the beginning of the +#' file with a of zero. #' @param nbytes A scalar value with the number of bytes to be read. #' @param ctx (optional) A TileDB Ctx object #' @return The binary file content is returned as an integer vector. #' @export tiledb_vfs_read <- function(fh, offset, nbytes, ctx = tiledb_get_context()) { - if (missing(offset)) offset <- bit64::as.integer64(0) - if (is.numeric(offset)) offset <- bit64::as.integer64(offset) - if (is.numeric(nbytes)) nbytes <- bit64::as.integer64(nbytes) - stopifnot("Argument 'fh' must be an external pointer" = is(fh, "externalptr"), - "Argument 'offset' must be integer64" = is(offset, "integer64"), - "Argument 'nbytes' currently a required parameter" = !missing(nbytes), - "Argument 'nbytes' must be integer64" = is(nbytes, "integer64"), - "Argument 'ctx' must be a tiledb_ctx object" = is(ctx, "tiledb_ctx")) - libtiledb_vfs_read(ctx@ptr, fh, offset, nbytes) + if (missing(offset)) offset <- bit64::as.integer64(0) + if (is.numeric(offset)) offset <- bit64::as.integer64(offset) + if (is.numeric(nbytes)) nbytes <- bit64::as.integer64(nbytes) + stopifnot( + "Argument 'fh' must be an external pointer" = is(fh, "externalptr"), + "Argument 'offset' must be integer64" = is(offset, "integer64"), + "Argument 'nbytes' currently a required parameter" = !missing(nbytes), + "Argument 'nbytes' must be integer64" = is(nbytes, "integer64"), + "Argument 'ctx' must be a tiledb_ctx object" = is(ctx, "tiledb_ctx") + ) + libtiledb_vfs_read(ctx@ptr, fh, offset, nbytes) } #' Return VFS Directory Size @@ -367,8 +422,10 @@ tiledb_vfs_read <- function(fh, offset, nbytes, ctx = tiledb_get_context()) { #' @return The size of the directory #' @export tiledb_vfs_dir_size <- function(uri, vfs = tiledb_get_vfs()) { - stopifnot(`Argument 'vfs' must be a tiledb_vfs object` = is(vfs, "tiledb_vfs"), - `Argument 'uri' must be character` = is.character(uri)) + stopifnot( + `Argument 'vfs' must be a tiledb_vfs object` = is(vfs, "tiledb_vfs"), + `Argument 'uri' must be character` = is.character(uri) + ) libtiledb_vfs_dir_size(vfs@ptr, uri) } @@ -379,8 +436,10 @@ tiledb_vfs_dir_size <- function(uri, vfs = tiledb_get_vfs()) { #' @return The content of the directory, non-recursive #' @export tiledb_vfs_ls <- function(uri, vfs = tiledb_get_vfs()) { - stopifnot(`Argument 'vfs' must be a tiledb_vfs object` = is(vfs, "tiledb_vfs"), - `Argument 'uri' must be character` = is.character(uri)) + stopifnot( + `Argument 'vfs' must be a tiledb_vfs object` = is(vfs, "tiledb_vfs"), + `Argument 'uri' must be character` = is.character(uri) + ) libtiledb_vfs_ls(vfs@ptr, uri) } @@ -391,17 +450,19 @@ tiledb_vfs_ls <- function(uri, vfs = tiledb_get_vfs()) { #' @return The unserialized object #' @export tiledb_vfs_unserialize <- function(uri, vfs = tiledb_get_vfs()) { - stopifnot("Argument 'vfs' must be a tiledb_vfs object" = is(vfs, "tiledb_vfs"), - "Argument 'uri' must be character" = is.character(uri)) - n <- tiledb_vfs_file_size(uri) - fh <- tiledb_vfs_open(uri, "READ") - vec <- tiledb_vfs_read(fh, 0, n) - tiledb_vfs_close(fh) - libtiledb_vfs_fh_free(fh) - ## The gzcon(rawConnection()) idea is from https://stackoverflow.com/a/58136567/508431 - ## The packBits(intToBits()) part on the int vector read is from a friend via slack - obj <- unserialize(gzcon(rawConnection(packBits(intToBits(vec))))) - obj + stopifnot( + "Argument 'vfs' must be a tiledb_vfs object" = is(vfs, "tiledb_vfs"), + "Argument 'uri' must be character" = is.character(uri) + ) + n <- tiledb_vfs_file_size(uri) + fh <- tiledb_vfs_open(uri, "READ") + vec <- tiledb_vfs_read(fh, 0, n) + tiledb_vfs_close(fh) + libtiledb_vfs_fh_free(fh) + ## The gzcon(rawConnection()) idea is from https://stackoverflow.com/a/58136567/508431 + ## The packBits(intToBits()) part on the int vector read is from a friend via slack + obj <- unserialize(gzcon(rawConnection(packBits(intToBits(vec))))) + obj } @@ -413,28 +474,30 @@ tiledb_vfs_unserialize <- function(uri, vfs = tiledb_get_vfs()) { #' @return The uri is returned invisibly #' @export tiledb_vfs_serialize <- function(obj, uri, vfs = tiledb_get_vfs()) { - stopifnot("Argument 'vfs' must be a tiledb_vfs object" = is(vfs, "tiledb_vfs"), - "Argument 'uri' must be character" = is.character(uri)) - ## We could not find a direct conversion of the 'raw' vector we get from serialize() - ## into a format that corresponded to what saveRDS() writes so we cheat a little - tf <- tempfile() - saveRDS(obj, tf) - - ## Read local file - fh <- tiledb_vfs_open(tf, "READ") - vec <- tiledb_vfs_read(fh, 0, tiledb_vfs_file_size(tf)) - tiledb_vfs_close(fh) - libtiledb_vfs_fh_free(fh) - - ## Now write 'vec' to the target URI - fh <- tiledb_vfs_open(uri, "WRITE") - tiledb_vfs_write(fh, vec) - tiledb_vfs_sync(fh) - tiledb_vfs_close(fh) - libtiledb_vfs_fh_free(fh) - - unlink(tf) - invisible(uri) + stopifnot( + "Argument 'vfs' must be a tiledb_vfs object" = is(vfs, "tiledb_vfs"), + "Argument 'uri' must be character" = is.character(uri) + ) + ## We could not find a direct conversion of the 'raw' vector we get from serialize() + ## into a format that corresponded to what saveRDS() writes so we cheat a little + tf <- tempfile() + saveRDS(obj, tf) + + ## Read local file + fh <- tiledb_vfs_open(tf, "READ") + vec <- tiledb_vfs_read(fh, 0, tiledb_vfs_file_size(tf)) + tiledb_vfs_close(fh) + libtiledb_vfs_fh_free(fh) + + ## Now write 'vec' to the target URI + fh <- tiledb_vfs_open(uri, "WRITE") + tiledb_vfs_write(fh, vec) + tiledb_vfs_sync(fh) + tiledb_vfs_close(fh) + libtiledb_vfs_fh_free(fh) + + unlink(tf) + invisible(uri) } #' Copy a file to VFS @@ -445,11 +508,13 @@ tiledb_vfs_serialize <- function(obj, uri, vfs = tiledb_get_vfs()) { #' @return The uri value of the removed file #' @export tiledb_vfs_copy_file <- function(file, uri, vfs = tiledb_get_vfs()) { - stopifnot("Argument 'vfs' must be a tiledb_vfs object" = is(vfs, "tiledb_vfs"), - "Argument 'uri' must be character" = is.character(uri), - "Argument 'file' must be character and point to a file" = - is.character(uri) && file.exists(file)) - libtiledb_vfs_copy_file(vfs@ptr, file, uri) + stopifnot( + "Argument 'vfs' must be a tiledb_vfs object" = is(vfs, "tiledb_vfs"), + "Argument 'uri' must be character" = is.character(uri), + "Argument 'file' must be character and point to a file" = + is.character(uri) && file.exists(file) + ) + libtiledb_vfs_copy_file(vfs@ptr, file, uri) } #' Recursively list objects from given URI @@ -462,10 +527,16 @@ tiledb_vfs_copy_file <- function(file, uri, vfs = tiledb_get_vfs()) { #' @return A data.frame object with two columns for the full path and the object #' size in bytes #' @export -tiledb_vfs_ls_recursive <- function(uri, vfs = tiledb_get_vfs(), ctx = tiledb_get_context()) { - stopifnot("Argument 'vfs' must be a tiledb_vfs object" = is(vfs, "tiledb_vfs"), - "Argument 'ctx' must be a tiledb_ctx object" = is(ctx, "tiledb_ctx"), - "Argument 'uri' must be character variable" = is.character(uri), - "This function needs TileDB 2.22.0 or later" = tiledb_version(TRUE) >= "2.22.0") - libtiledb_vfs_ls_recursive(ctx@ptr, vfs@ptr, uri) +tiledb_vfs_ls_recursive <- function( + uri, + vfs = tiledb_get_vfs(), + ctx = tiledb_get_context() +) { + stopifnot( + "Argument 'vfs' must be a tiledb_vfs object" = is(vfs, "tiledb_vfs"), + "Argument 'ctx' must be a tiledb_ctx object" = is(ctx, "tiledb_ctx"), + "Argument 'uri' must be character variable" = is.character(uri), + "This function needs TileDB 2.22.0 or later" = tiledb_version(TRUE) >= "2.22.0" + ) + libtiledb_vfs_ls_recursive(ctx@ptr, vfs@ptr, uri) } diff --git a/R/Version.R b/R/Version.R index a0a55c567e..099d42c333 100644 --- a/R/Version.R +++ b/R/Version.R @@ -27,14 +27,17 @@ #' @return An named int vector c(major, minor, patch), or if select, #' a \code{package_version} object #' @examples -#' \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +#' \dontshow{ +#' ctx <- tiledb_ctx(limitTileDBCores()) +#' } #' tiledb_version() #' tiledb_version(compact = TRUE) #' @export tiledb_version <- function(compact = FALSE) { - stopifnot(`Argument 'compact' must be logical` = is.logical(compact)) - if (compact) - as.package_version(paste(unname(tiledb_version()), collapse=".")) - else - libtiledb_version() + stopifnot(`Argument 'compact' must be logical` = is.logical(compact)) + if (compact) { + as.package_version(paste(unname(tiledb_version()), collapse = ".")) + } else { + libtiledb_version() + } } diff --git a/man/array_consolidate.Rd b/man/array_consolidate.Rd index b64638e12e..e5435442fb 100644 --- a/man/array_consolidate.Rd +++ b/man/array_consolidate.Rd @@ -17,7 +17,8 @@ array_consolidate( \item{cfg}{An optional TileDB Configuration object} -\item{start_time}{An optional timestamp value, if missing config default is used} +\item{start_time}{An optional timestamp value, if missing config +default is used} \item{end_time}{An optional timestamp value, if missing config default is used} @@ -27,7 +28,7 @@ array_consolidate( NULL is returned invisibly } \description{ -This function invokes a consolidation operation. Parameters affecting the operation -can be set via an optional configuration object. Start and end timestamps can also be -set directly. +This function invokes a consolidation operation. Parameters affecting the +operation can be set via an optional configuration object. Start and end +timestamps can also be set directly. } diff --git a/man/array_vacuum.Rd b/man/array_vacuum.Rd index 5ea47bde2d..b3fc38bc1f 100644 --- a/man/array_vacuum.Rd +++ b/man/array_vacuum.Rd @@ -11,9 +11,11 @@ array_vacuum(uri, cfg = NULL, start_time, end_time, ctx = tiledb_get_context()) \item{cfg}{An optional TileDB Configuration object} -\item{start_time}{An optional timestamp value, if missing config default is used} +\item{start_time}{An optional timestamp value, if missing config +default is used} -\item{end_time}{An optional timestamp value, if missing config default is used} +\item{end_time}{An optional timestamp value, if missing config default +is used} \item{ctx}{An option TileDB Context object} } @@ -21,11 +23,11 @@ array_vacuum(uri, cfg = NULL, start_time, end_time, ctx = tiledb_get_context()) NULL is returned invisibly } \description{ -This function can remove fragments following a consolidation step. Note that vacuuming -should \emph{not} be run if one intends to use the TileDB \emph{time-traveling} feature -of opening arrays at particular timestamps. +This function can remove fragments following a consolidation step. Note that +vacuuming should \emph{not} be run if one intends to use the TileDB +\emph{time-traveling} feature of opening arrays at particular timestamps. } \details{ -Parameters affecting the operation can be set via an optional configuration object. -Start and end timestamps can also be set directly. +Parameters affecting the operation can be set via an optional configuration +object. Start and end timestamps can also be set directly. } diff --git a/man/as.vector.tiledb_config.Rd b/man/as.vector.tiledb_config.Rd index 16a3f05765..b9ff4875d2 100644 --- a/man/as.vector.tiledb_config.Rd +++ b/man/as.vector.tiledb_config.Rd @@ -18,7 +18,9 @@ a character vector of config parameter names, values Convert a \code{tiledb_config} object to a R vector } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} cfg <- tiledb_config() as.vector(cfg) diff --git a/man/attrs-set-tiledb_array-method.Rd b/man/attrs-set-tiledb_array-method.Rd index 02bce740c6..ef37a1261b 100644 --- a/man/attrs-set-tiledb_array-method.Rd +++ b/man/attrs-set-tiledb_array-method.Rd @@ -9,9 +9,9 @@ \arguments{ \item{x}{A \code{tiledb_array} object} -\item{value}{A character vector with attributes; the value \code{NA_character_} -signals no attributes should be returned; default is an empty character vector -implying all columns are returned.} +\item{value}{A character vector with attributes; the value +\code{NA_character_} signals no attributes should be returned; default is an +empty character vector implying all columns are returned.} } \value{ The modified \code{tiledb_array} object diff --git a/man/attrs-tiledb_array-ANY-method.Rd b/man/attrs-tiledb_array-ANY-method.Rd index b4091c1be1..238fc7cd24 100644 --- a/man/attrs-tiledb_array-ANY-method.Rd +++ b/man/attrs-tiledb_array-ANY-method.Rd @@ -15,6 +15,6 @@ a vector with attributes; \code{NA} means no attributes will be returned. } \description{ By default, all attributes will be selected. But if a subset of attribute -names is assigned to the internal slot \code{attrs}, then only those attributes -will be queried. This methods accesses the slot. +names is assigned to the internal slot \code{attrs}, then only those +attributes#' will be queried. This methods accesses the slot. } diff --git a/man/attrs-tiledb_array_schema-ANY-method.Rd b/man/attrs-tiledb_array_schema-ANY-method.Rd index 8892124f79..b80dbfb037 100644 --- a/man/attrs-tiledb_array_schema-ANY-method.Rd +++ b/man/attrs-tiledb_array_schema-ANY-method.Rd @@ -20,10 +20,14 @@ a list of tiledb_attr objects Returns a list of all \code{tiledb_attr} objects associated with the \code{tiledb_array_schema} } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} dom <- tiledb_domain(dims = c(tiledb_dim("d1", c(1L, 10L), type = "INT32"))) -sch <- tiledb_array_schema(dom, attrs = c(tiledb_attr("a1", type = "INT32"), - tiledb_attr("a2", type = "FLOAT64"))) +sch <- tiledb_array_schema(dom, attrs = c( + tiledb_attr("a1", type = "INT32"), + tiledb_attr("a2", type = "FLOAT64") +)) attrs(sch) lapply(attrs(sch), datatype) diff --git a/man/attrs-tiledb_array_schema-character-method.Rd b/man/attrs-tiledb_array_schema-character-method.Rd index 59cde6eec7..d70292735c 100644 --- a/man/attrs-tiledb_array_schema-character-method.Rd +++ b/man/attrs-tiledb_array_schema-character-method.Rd @@ -20,10 +20,14 @@ a \code{tiledb_attr} object Returns a \code{tiledb_attr} object associated with the \code{tiledb_array_schema} with a given name. } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} dom <- tiledb_domain(dims = c(tiledb_dim("d1", c(1L, 10L), type = "INT32"))) -sch <- tiledb_array_schema(dom, attrs = c(tiledb_attr("a1", type = "INT32"), - tiledb_attr("a2", type = "FLOAT64"))) +sch <- tiledb_array_schema(dom, attrs = c( + tiledb_attr("a1", type = "INT32"), + tiledb_attr("a2", type = "FLOAT64") +)) attrs(sch, "a2") } diff --git a/man/attrs-tiledb_array_schema-numeric-method.Rd b/man/attrs-tiledb_array_schema-numeric-method.Rd index 60fbe917a4..6531e644fc 100644 --- a/man/attrs-tiledb_array_schema-numeric-method.Rd +++ b/man/attrs-tiledb_array_schema-numeric-method.Rd @@ -20,10 +20,14 @@ a \code{tiledb_attr} object The attribute index is defined by the order the attributes were defined in the schema } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} dom <- tiledb_domain(dims = c(tiledb_dim("d1", c(1L, 10L), type = "INT32"))) -sch <- tiledb_array_schema(dom, attrs = c(tiledb_attr("a1", type = "INT32"), - tiledb_attr("a2", type = "FLOAT64"))) +sch <- tiledb_array_schema(dom, attrs = c( + tiledb_attr("a1", type = "INT32"), + tiledb_attr("a2", type = "FLOAT64") +)) attrs(sch, 2) } diff --git a/man/config-tiledb_ctx-method.Rd b/man/config-tiledb_ctx-method.Rd index e6d23bbf9f..9546a68d19 100644 --- a/man/config-tiledb_ctx-method.Rd +++ b/man/config-tiledb_ctx-method.Rd @@ -16,7 +16,9 @@ Retrieve the \code{tiledb_config} object from the \code{tiledb_ctx} } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} ctx <- tiledb_ctx(c("sm.tile_cache_size" = "10")) cfg <- config(ctx) cfg["sm.tile_cache_size"] diff --git a/man/datatype-tiledb_dim-method.Rd b/man/datatype-tiledb_dim-method.Rd index 66d5c7436e..278e4408ee 100644 --- a/man/datatype-tiledb_dim-method.Rd +++ b/man/datatype-tiledb_dim-method.Rd @@ -16,7 +16,9 @@ tiledb datatype string Return the \code{tiledb_dim} datatype } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} d1 <- tiledb_dim("d1", domain = c(5L, 10L), tile = 2L, type = "INT32") datatype(d1) diff --git a/man/datatype-tiledb_domain-method.Rd b/man/datatype-tiledb_domain-method.Rd index 11395ac6fd..e96073e520 100644 --- a/man/datatype-tiledb_domain-method.Rd +++ b/man/datatype-tiledb_domain-method.Rd @@ -16,7 +16,9 @@ tiledb_domain type string Returns the tiledb_domain TileDB type string } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} dom <- tiledb_domain(dims = c(tiledb_dim("d1", c(1L, 100L), type = "INT32"))) datatype(dom) dom <- tiledb_domain(dims = c(tiledb_dim("d1", c(0.5, 100.0), type = "FLOAT64"))) diff --git a/man/datetimes_as_int64-set-tiledb_array-method.Rd b/man/datetimes_as_int64-set-tiledb_array-method.Rd index 71f66a24cb..daba4dbf82 100644 --- a/man/datetimes_as_int64-set-tiledb_array-method.Rd +++ b/man/datetimes_as_int64-set-tiledb_array-method.Rd @@ -18,8 +18,9 @@ datetimes_as_int64(x) <- value The modified \code{tiledb_array} array object } \description{ -A \code{tiledb_array} object may contain date and datetime objects. While their internal -representation is generally shielded from the user, it can useful to access them as the -\sQuote{native} format which is an \code{integer64}. This function set the current -value of the selection variable, which has a default of \code{FALSE}. +A \code{tiledb_array} object may contain date and datetime objects. While +their internal representation is generally shielded from the user, it can +useful to access them as the \sQuote{native} format which is an +\code{integer64}. This function set the current value of the selection +variable, which has a default of \code{FALSE}. } diff --git a/man/datetimes_as_int64-tiledb_array-method.Rd b/man/datetimes_as_int64-tiledb_array-method.Rd index 36784a9dc4..6b2429291c 100644 --- a/man/datetimes_as_int64-tiledb_array-method.Rd +++ b/man/datetimes_as_int64-tiledb_array-method.Rd @@ -13,11 +13,13 @@ datetimes_as_int64(object) \item{object}{A \code{tiledb_array} object} } \value{ -A logical value indicating whether \code{datetimes_as_int64} is selected +A logical value indicating whether \code{datetimes_as_int64} +is selected } \description{ -A \code{tiledb_array} object may contain date and datetime objects. While their internal -representation is generally shielded from the user, it can useful to access them as the -\sQuote{native} format which is an \code{integer64}. This function retrieves the current -value of the selection variable, which has a default of \code{FALSE}. +A \code{tiledb_array} object may contain date and datetime objects. While +their internal representation is generally shielded from the user, it can +useful to access them as the \sQuote{native} format which is an +\code{integer64}. This function retrieves the current value of the selection +variable, which has a default of \code{FALSE}. } diff --git a/man/dim.tiledb_array_schema.Rd b/man/dim.tiledb_array_schema.Rd index 2b3d8fdc24..f1e2153c5b 100644 --- a/man/dim.tiledb_array_schema.Rd +++ b/man/dim.tiledb_array_schema.Rd @@ -16,10 +16,14 @@ a dimension vector Only valid for integral (integer) domains } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} dom <- tiledb_domain(dims = c(tiledb_dim("d1", c(1L, 10L), type = "INT32"))) -sch <- tiledb_array_schema(dom, attrs = c(tiledb_attr("a1", type = "INT32"), - tiledb_attr("a2", type = "FLOAT64"))) +sch <- tiledb_array_schema(dom, attrs = c( + tiledb_attr("a1", type = "INT32"), + tiledb_attr("a2", type = "FLOAT64") +)) dim(sch) } diff --git a/man/dim.tiledb_dim.Rd b/man/dim.tiledb_dim.Rd index 420f08b07a..25d263489f 100644 --- a/man/dim.tiledb_dim.Rd +++ b/man/dim.tiledb_dim.Rd @@ -16,7 +16,9 @@ a vector of the tile_dim domain type, of the dim domain dimension (extent) Retrieves the dimension of the tiledb_dim domain } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} d1 <- tiledb_dim("d1", c(1L, 10L), 5L) dim(d1) diff --git a/man/dim.tiledb_domain.Rd b/man/dim.tiledb_domain.Rd index 5f5ba904bc..0ff154d8ab 100644 --- a/man/dim.tiledb_domain.Rd +++ b/man/dim.tiledb_domain.Rd @@ -16,9 +16,13 @@ dimension vector Only valid for integral (integer) domains } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} -dom <- tiledb_domain(dims = c(tiledb_dim("d1", c(1L, 100L), type = "INT32"), - tiledb_dim("d2", c(1L, 100L), type = "INT32"))) +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} +dom <- tiledb_domain(dims = c( + tiledb_dim("d1", c(1L, 100L), type = "INT32"), + tiledb_dim("d2", c(1L, 100L), type = "INT32") +)) dim(dom) } diff --git a/man/dimensions-tiledb_array_schema-method.Rd b/man/dimensions-tiledb_array_schema-method.Rd index d503cd3218..39a6cd0f67 100644 --- a/man/dimensions-tiledb_array_schema-method.Rd +++ b/man/dimensions-tiledb_array_schema-method.Rd @@ -16,9 +16,13 @@ a list of tiledb_dim objects Returns a list of \code{tiledb_dim} objects associated with the \code{tiledb_array_schema} } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} -dom <- tiledb_domain(dims = c(tiledb_dim("d1", c(1L, 100L), type = "INT32"), - tiledb_dim("d2", c(1L, 50L), type = "INT32"))) +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} +dom <- tiledb_domain(dims = c( + tiledb_dim("d1", c(1L, 100L), type = "INT32"), + tiledb_dim("d2", c(1L, 50L), type = "INT32") +)) sch <- tiledb_array_schema(dom, attrs = c(tiledb_attr("a1", type = "INT32"))) dimensions(dom) diff --git a/man/dimensions-tiledb_domain-method.Rd b/man/dimensions-tiledb_domain-method.Rd index 95167d6d13..1f0938d091 100644 --- a/man/dimensions-tiledb_domain-method.Rd +++ b/man/dimensions-tiledb_domain-method.Rd @@ -16,9 +16,13 @@ a list of tiledb_dim Returns a list of the tiledb_domain dimension objects } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} -dom <- tiledb_domain(dims = c(tiledb_dim("d1", c(1L, 100L), type = "INT32"), - tiledb_dim("d2", c(1L, 50L), type = "INT32"))) +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} +dom <- tiledb_domain(dims = c( + tiledb_dim("d1", c(1L, 100L), type = "INT32"), + tiledb_dim("d2", c(1L, 50L), type = "INT32") +)) dimensions(dom) lapply(dimensions(dom), name) diff --git a/man/domain-tiledb_array_schema-method.Rd b/man/domain-tiledb_array_schema-method.Rd index 144c76ed1c..3a235d6818 100644 --- a/man/domain-tiledb_array_schema-method.Rd +++ b/man/domain-tiledb_array_schema-method.Rd @@ -13,7 +13,9 @@ Returns the \code{tiledb_domain} object associated with a given \code{tiledb_array_schema} } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} dom <- tiledb_domain(dims = c(tiledb_dim("d1", c(1L, 10L), type = "INT32"))) sch <- tiledb_array_schema(dom, attrs = c(tiledb_attr("a1", type = "INT32"))) domain(sch) diff --git a/man/domain-tiledb_dim-method.Rd b/man/domain-tiledb_dim-method.Rd index 34285e64a6..15cfaa3a56 100644 --- a/man/domain-tiledb_dim-method.Rd +++ b/man/domain-tiledb_dim-method.Rd @@ -16,7 +16,9 @@ a vector of (lb, ub) inclusive domain of the dimension Return the \code{tiledb_dim} domain } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} d1 <- tiledb_dim("d1", domain = c(5L, 10L)) domain(d1) diff --git a/man/extended-set-tiledb_array-method.Rd b/man/extended-set-tiledb_array-method.Rd index c22a40e5c1..edf3b8a712 100644 --- a/man/extended-set-tiledb_array-method.Rd +++ b/man/extended-set-tiledb_array-method.Rd @@ -18,7 +18,7 @@ extended(x) <- value The modified \code{tiledb_array} array object } \description{ -A \code{tiledb_array} object can be returned as \code{data.frame}. This methods -set the selection value for \sQuote{extended} format including row (and column, -if present) indices. +A \code{tiledb_array} object can be returned as \code{data.frame}. This +methods set the selection value for \sQuote{extended} format including row +(and column, if present) indices. } diff --git a/man/extended-tiledb_array-method.Rd b/man/extended-tiledb_array-method.Rd index 4dd3512d09..49b44898b1 100644 --- a/man/extended-tiledb_array-method.Rd +++ b/man/extended-tiledb_array-method.Rd @@ -13,10 +13,11 @@ extended(object) \item{object}{A \code{tiledb_array} object} } \value{ -A logical value indicating whether an \code{extended} return is selected +A logical value indicating whether an \code{extended} +return is selected } \description{ -A \code{tiledb_array} object can be returned as \code{data.frame}. This methods -returns the selection value for \sQuote{extended} format including row (and column, -if present) indices. +A \code{tiledb_array} object can be returned as \code{data.frame}. This +methods returns the selection value for \sQuote{extended} format including +row (and column, if present) indices. } diff --git a/man/filter_list-tiledb_attr-method.Rd b/man/filter_list-tiledb_attr-method.Rd index 843b36e3bf..4c12c5874d 100644 --- a/man/filter_list-tiledb_attr-method.Rd +++ b/man/filter_list-tiledb_attr-method.Rd @@ -16,8 +16,13 @@ a tiledb_filter_list object Returns the TileDB Filter List object associated with the given TileDB Attribute } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} -attr <- tiledb_attr(type = "INT32", filter_list=tiledb_filter_list(list(tiledb_filter("ZSTD")))) +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} +attr <- tiledb_attr( + type = "INT32", + filter_list = tiledb_filter_list(list(tiledb_filter("ZSTD"))) +) filter_list(attr) } diff --git a/man/fromSparseMatrix.Rd b/man/fromSparseMatrix.Rd index 0c490f137f..6c26a7cea0 100644 --- a/man/fromSparseMatrix.Rd +++ b/man/fromSparseMatrix.Rd @@ -43,16 +43,16 @@ The functions \code{fromSparseMatrix} and \code{toSparseMatrix} help in storing \dontshow{ctx <- tiledb_ctx(limitTileDBCores())} \dontrun{ if (requireNamespace("Matrix", quietly=TRUE)) { - library(Matrix) - set.seed(123) # just to fix it - mat <- matrix(0, nrow=20, ncol=10) - mat[sample(seq_len(200), 20)] <- seq(1, 20) - spmat <- as(mat, "dgTMatrix") # sparse matrix in dgTMatrix format - uri <- "sparse_matrix" - fromSparseMatrix(spmat, uri) # now written - chk <- toSparseMatrix(uri) # and re-read - print(chk) - all.equal(spmat, chk) + library(Matrix) + set.seed(123) # just to fix it + mat <- matrix(0, nrow=20, ncol=10) + mat[sample(seq_len(200), 20)] <- seq(1, 20) + spmat <- as(mat, "dgTMatrix") # sparse matrix in dgTMatrix format + uri <- "sparse_matrix" + fromSparseMatrix(spmat, uri) # now written + chk <- toSparseMatrix(uri) # and re-read + print(chk) + all.equal(spmat, chk) } } } diff --git a/man/is.anonymous.Rd b/man/is.anonymous.Rd index c274716e56..f670f4eabf 100644 --- a/man/is.anonymous.Rd +++ b/man/is.anonymous.Rd @@ -19,7 +19,9 @@ TRUE or FALSE A TileDB attribute is anonymous if no name/label is defined } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} a1 <- tiledb_attr("a1", type = "FLOAT64") is.anonymous(a1) diff --git a/man/is.anonymous.tiledb_dim.Rd b/man/is.anonymous.tiledb_dim.Rd index 22952cd426..1f619b2eb6 100644 --- a/man/is.anonymous.tiledb_dim.Rd +++ b/man/is.anonymous.tiledb_dim.Rd @@ -16,7 +16,9 @@ TRUE or FALSE A TileDB dimension is anonymous if no name/label is defined } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} d1 <- tiledb_dim("d1", c(1L, 10L), 10L) is.anonymous(d1) diff --git a/man/is.integral-tiledb_domain-method.Rd b/man/is.integral-tiledb_domain-method.Rd index fe959b511a..4e32473a33 100644 --- a/man/is.integral-tiledb_domain-method.Rd +++ b/man/is.integral-tiledb_domain-method.Rd @@ -16,7 +16,9 @@ TRUE if the domain is an integral domain, else FALSE Returns TRUE is tiledb_domain is an integral (integer) domain } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} dom <- tiledb_domain(dims = c(tiledb_dim("d1", c(1L, 100L), type = "INT32"))) is.integral(dom) dom <- tiledb_domain(dims = c(tiledb_dim("d1", c(0.5, 100.0), type = "FLOAT64"))) diff --git a/man/name-tiledb_attr-method.Rd b/man/name-tiledb_attr-method.Rd index 3b517465ce..f006b7a867 100644 --- a/man/name-tiledb_attr-method.Rd +++ b/man/name-tiledb_attr-method.Rd @@ -16,7 +16,9 @@ string name, empty string if the attribute is anonymous Return the \code{tiledb_attr} name } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} a1 <- tiledb_attr("a1", type = "INT32") name(a1) diff --git a/man/name-tiledb_dim-method.Rd b/man/name-tiledb_dim-method.Rd index 5746496328..05163bb11f 100644 --- a/man/name-tiledb_dim-method.Rd +++ b/man/name-tiledb_dim-method.Rd @@ -16,7 +16,9 @@ string name, empty string if the dimension is anonymous Return the \code{tiledb_dim} name } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} d1 <- tiledb_dim("d1", c(1L, 10L)) name(d1) diff --git a/man/nfilters-tiledb_filter_list-method.Rd b/man/nfilters-tiledb_filter_list-method.Rd index b68515ca99..9c2b997ef4 100644 --- a/man/nfilters-tiledb_filter_list-method.Rd +++ b/man/nfilters-tiledb_filter_list-method.Rd @@ -16,7 +16,9 @@ integer number of filters Returns the filter_list's number of filters } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} flt <- tiledb_filter("ZSTD") tiledb_filter_set_option(flt, "COMPRESSION_LEVEL", 5) filter_list <- tiledb_filter_list(c(flt)) diff --git a/man/parse_query_condition.Rd b/man/parse_query_condition.Rd index 57afae023c..b0c619b423 100644 --- a/man/parse_query_condition.Rd +++ b/man/parse_query_condition.Rd @@ -45,12 +45,16 @@ the data type is difficult to guess. Also, when using the \code{"\%in\%"} or \co the argument is mandatory. } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} \dontrun{ -uri <- "mem://airquality" # change to on-disk for persistence -fromDataFrame(airquality, uri, col_index=c("Month", "Day")) # dense array +uri <- "mem://airquality" # change to on-disk for persistence +fromDataFrame(airquality, uri, col_index = c("Month", "Day")) # dense array ## query condition on dense array requires extended=FALSE -tiledb_array(uri, return_as="data.frame", extended=FALSE, - query_condition=parse_query_condition(Temp > 90))[] +tiledb_array(uri, + return_as = "data.frame", extended = FALSE, + query_condition = parse_query_condition(Temp > 90) +)[] } } diff --git a/man/query_condition-set-tiledb_array-method.Rd b/man/query_condition-set-tiledb_array-method.Rd index c19894eb6f..4aaf4ec35e 100644 --- a/man/query_condition-set-tiledb_array-method.Rd +++ b/man/query_condition-set-tiledb_array-method.Rd @@ -18,6 +18,7 @@ query_condition(x) <- value The modified \code{tiledb_array} array object } \description{ -A \code{tiledb_array} object can have an associated query condition object to set -conditions on the read queries. This methods sets the \sQuote{query_condition} object. +A \code{tiledb_array} object can have an associated query condition object to +set conditions on the read queries. This methods sets the +\sQuote{query_condition} object. } diff --git a/man/query_layout-set-tiledb_array-method.Rd b/man/query_layout-set-tiledb_array-method.Rd index 217e6ffc9f..daa113bf7d 100644 --- a/man/query_layout-set-tiledb_array-method.Rd +++ b/man/query_layout-set-tiledb_array-method.Rd @@ -12,14 +12,15 @@ query_layout(x) <- value \arguments{ \item{x}{A \code{tiledb_array} object} -\item{value}{A character variable for the query layout. Permitted values are -\dQuote{ROW_MAJOR}, \dQuote{COL_MAJOR}, \dQuote{GLOBAL_ORDER}, or \dQuote{UNORDERD}.} +\item{value}{A character variable for the query layout. Permitted values +are \dQuote{ROW_MAJOR}, \dQuote{COL_MAJOR}, \dQuote{GLOBAL_ORDER}, or +\dQuote{UNORDERD}.} } \value{ The modified \code{tiledb_array} array object } \description{ -A \code{tiledb_array} object can have an associated query with a specific layout. -This methods sets the selection value for \sQuote{query_layout} from a character -value. +A \code{tiledb_array} object can have an associated query with a specific +layout. This methods sets the selection value for \sQuote{query_layout} +from a character value. } diff --git a/man/query_layout-tiledb_array-method.Rd b/man/query_layout-tiledb_array-method.Rd index 53dadec934..e23775351d 100644 --- a/man/query_layout-tiledb_array-method.Rd +++ b/man/query_layout-tiledb_array-method.Rd @@ -16,7 +16,7 @@ query_layout(object) A character value describing the query layout } \description{ -A \code{tiledb_array} object can have a corresponding query with a given layout -given layout. This methods returns the selection value for \sQuote{query_layout} -as a character value. +A \code{tiledb_array} object can have a corresponding query with a given +layout given layout. This methods returns the selection value for +\sQuote{query_layout} as a character value. } diff --git a/man/query_statistics-set-tiledb_array-method.Rd b/man/query_statistics-set-tiledb_array-method.Rd index 26e945043c..3cff8f09f0 100644 --- a/man/query_statistics-set-tiledb_array-method.Rd +++ b/man/query_statistics-set-tiledb_array-method.Rd @@ -18,7 +18,8 @@ query_statistics(x) <- value The modified \code{tiledb_array} array object } \description{ -A \code{tiledb_array} object can, if requested, return query statistics as a JSON -string in an attribute \sQuote{query_statistics} attached to the return object. The -default value of the logical switch is \sQuote{FALSE}. This method sets the value. +A \code{tiledb_array} object can, if requested, return query statistics as a +JSON string in an attribute \sQuote{query_statistics} attached to the return +object. The default value of the logical switch is \sQuote{FALSE}. This +method sets the value. } diff --git a/man/query_statistics-tiledb_array-method.Rd b/man/query_statistics-tiledb_array-method.Rd index 4a0e11c449..e5c36c7440 100644 --- a/man/query_statistics-tiledb_array-method.Rd +++ b/man/query_statistics-tiledb_array-method.Rd @@ -18,8 +18,8 @@ query_statistics(object, ...) A logical value indicating whether query statistics are returned. } \description{ -A \code{tiledb_array} object can, if requested, return query statistics as a JSON -string in an attribute \sQuote{query_statistics} attached to the return object. The -default value of the logical switch is \sQuote{FALSE}. This method returns the current -value. +A \code{tiledb_array} object can, if requested, return query statistics as a +JSON string in an attribute \sQuote{query_statistics} attached to the return +object. The default value of the logical switch is \sQuote{FALSE}. This +method returns the current value. } diff --git a/man/return.array-set-tiledb_array-method.Rd b/man/return.array-set-tiledb_array-method.Rd index ae0e24275e..746c6ce1b9 100644 --- a/man/return.array-set-tiledb_array-method.Rd +++ b/man/return.array-set-tiledb_array-method.Rd @@ -19,6 +19,6 @@ The modified \code{tiledb_array} array object } \description{ A \code{tiledb_array} object can be returned as an array (or list of arrays), -or, if select, as a \code{data.frame} or a \code{matrix}. This methods sets the -selection value for a \code{array}. +or, if select, as a \code{data.frame} or a \code{matrix}. This methods sets +the selection value for a \code{array}. } diff --git a/man/return.array-tiledb_array-method.Rd b/man/return.array-tiledb_array-method.Rd index 54b7beae2c..6d15aa0102 100644 --- a/man/return.array-tiledb_array-method.Rd +++ b/man/return.array-tiledb_array-method.Rd @@ -19,6 +19,6 @@ A logical value indicating whether \code{array} return is selected } \description{ A \code{tiledb_array} object can be returned as an array (or list of arrays), -or, if select, as a \code{data.frame} or as a \code{matrix}. This methods returns -the selection value for the \code{array} selection. +or, if select, as a \code{data.frame} or as a \code{matrix}. This methods +returns the selection value for the \code{array} selection. } diff --git a/man/return.data.frame-tiledb_array-method.Rd b/man/return.data.frame-tiledb_array-method.Rd index 17ef321bf6..326fa066e0 100644 --- a/man/return.data.frame-tiledb_array-method.Rd +++ b/man/return.data.frame-tiledb_array-method.Rd @@ -10,9 +10,11 @@ \item{object}{A \code{tiledb_array} object} } \value{ -A logical value indicating whether \code{data.frame} return is selected +A logical value indicating whether \code{data.frame} return +is selected } \description{ A \code{tiledb_array} object can be returned as an array (or list of arrays), -or, if select, as a \code{data.frame}. This methods returns the selection value. +or, if select, as a \code{data.frame}. This methods returns the +selection value. } diff --git a/man/return.matrix-set-tiledb_array-method.Rd b/man/return.matrix-set-tiledb_array-method.Rd index 85bb502ae9..b9e43c3a10 100644 --- a/man/return.matrix-set-tiledb_array-method.Rd +++ b/man/return.matrix-set-tiledb_array-method.Rd @@ -19,6 +19,6 @@ The modified \code{tiledb_array} array object } \description{ A \code{tiledb_array} object can be returned as an array (or list of arrays), -or, if select, as a \code{data.frame} or a \code{matrix}. This methods sets the -selection value for a \code{matrix}. +or, if select, as a \code{data.frame} or a \code{matrix}. This methods sets +the selection value for a \code{matrix}. } diff --git a/man/return.matrix-tiledb_array-method.Rd b/man/return.matrix-tiledb_array-method.Rd index 6ccfddbfc0..fa6b99d144 100644 --- a/man/return.matrix-tiledb_array-method.Rd +++ b/man/return.matrix-tiledb_array-method.Rd @@ -19,6 +19,6 @@ A logical value indicating whether \code{matrix} return is selected } \description{ A \code{tiledb_array} object can be returned as an array (or list of arrays), -or, if select, as a \code{data.frame} or as a \code{matrix}. This methods returns -the selection value for the \code{matrix} selection. +or, if select, as a \code{data.frame} or as a \code{matrix}. This methods +returns the selection value for the \code{matrix} selection. } diff --git a/man/return_as-set-tiledb_array-method.Rd b/man/return_as-set-tiledb_array-method.Rd index df74a1bc4c..1df16511f7 100644 --- a/man/return_as-set-tiledb_array-method.Rd +++ b/man/return_as-set-tiledb_array-method.Rd @@ -18,9 +18,10 @@ return_as(x) <- value The modified \code{tiledb_array} array object } \description{ -A \code{tiledb_array} object can be returned as a \sQuote{list} (default), \sQuote{array}, -\sQuote{matrix}, \sQuote{data.frame}, \sQuote{data.table} or \sQuote{tibble}. This method -This methods permits to set a preference of returning a \code{list}, \code{array}, -\code{matrix}, \code{data.frame}, a \code{data.table}, or a \code{tibble}. The default -value of \dQuote{asis} means that no conversion is performed and a \code{list} is returned. +A \code{tiledb_array} object can be returned as a \sQuote{list} (default), +\sQuote{array}, \sQuote{matrix}, \sQuote{data.frame}, \sQuote{data.table} or +\sQuote{tibble}. This method This methods permits to set a preference of +returning a \code{list}, \code{array}, \code{matrix}, \code{data.frame}, a +\code{data.table}, or a \code{tibble}. The default value of \dQuote{asis} +means that no conversion is performed and a \code{list} is returned. } diff --git a/man/return_as-tiledb_array-method.Rd b/man/return_as-tiledb_array-method.Rd index 8dae06317d..0c7c4b3e11 100644 --- a/man/return_as-tiledb_array-method.Rd +++ b/man/return_as-tiledb_array-method.Rd @@ -15,13 +15,14 @@ return_as(object, ...) \item{...}{Currently unused} } \value{ -A character value indicating the preferred conversion where the value is -one of \sQuote{asis} (the default), \sQuote{array}, \sQuote{matrix},\sQuote{data.frame}, -\sQuote{data.table}, or \sQuote{tibble}. +A character value indicating the preferred conversion where the value +is one of \sQuote{asis} (the default), \sQuote{array}, +\sQuote{matrix},\sQuote{data.frame}, \sQuote{data.table}, or \sQuote{tibble}. } \description{ -A \code{tiledb_array} object can be returned as a \sQuote{list} (default), \sQuote{array}, -\sQuote{matrix}, \sQuote{data.frame}, \sQuote{data.table} or \sQuote{tibble}. This method -permits to select a preference for the returned object. The default value of \sQuote{asis} -means that no conversion is performed. +A \code{tiledb_array} object can be returned as a \sQuote{list} (default), +\sQuote{array}, \sQuote{matrix}, \sQuote{data.frame}, \sQuote{data.table} or +\sQuote{tibble}. This method permits to select a preference for the returned +object. The default value of \sQuote{asis} means that no conversion +is performed. } diff --git a/man/save_allocation_size_preference.Rd b/man/save_allocation_size_preference.Rd index 4b701df89c..5851fa8def 100644 --- a/man/save_allocation_size_preference.Rd +++ b/man/save_allocation_size_preference.Rd @@ -19,8 +19,9 @@ set_allocation_size_preference(value) \item{value}{A numeric value with the desired allocation size (in bytes).} } \value{ -For the setter, \code{TRUE} is returned invisibly but the function is invoked for the -side effect of storing the value. For the getters, the value as a numeric. +For the setter, \code{TRUE} is returned invisibly but the function is +invoked for the side effect of storing the value. For the getters, the +value as a numeric. } \description{ Save (or load) allocation size default preference in an optional diff --git a/man/save_return_as_preference.Rd b/man/save_return_as_preference.Rd index c653dfc8b9..5fddb33afe 100644 --- a/man/save_return_as_preference.Rd +++ b/man/save_return_as_preference.Rd @@ -23,26 +23,30 @@ set_return_as_preference( \item{value}{A character variable with one of the six permitted values} } \value{ -For the setter, \code{TRUE} is returned invisibly but the function is invoked for the -side effect of storing the value. For either getter, the character value. +For the setter, \code{TRUE} is returned invisibly but the function +is invoked for the side effect of storing the value. For either getter, +the character value. } \description{ -Save (or load) \sQuote{return_as} conversion preference in an optional config file +Save (or load) \sQuote{return_as} conversion preference in an +optional config file } \details{ -The \code{tiledb_array} object can set a preference for conversion for each retrieved -object. This preference can also be enconded in a configuration file as R (version -4.0.0 or later) allows a user- and package specific configuration files. These helper -functions sets and retrieve the value, respectively, or retrieve the cached value from -the package environment where is it set at package load. +The \code{tiledb_array} object can set a preference for conversion for each +retrieved object. This preference can also be encoded in a configuration +file as R (version 4.0.0 or later) allows a user- and package specific +configuration files. These helper functions set and retrieve the value, +respectively, or retrieve the cached value from the package environment where +it is set at package load. -Note that the value must be one of \sQuote{asis} (the default), \sQuote{array}, -\sQuote{matrix}\sQuote{data.frame}, \sQuote{data.table} or \sQuote{tibble}. The latter -two require the corresponding package to be installed. +Note that the value must be one of \sQuote{asis} (the default), +\sQuote{array}, \sQuote{matrix}\sQuote{data.frame}, \sQuote{data.table} or +\sQuote{tibble}. The latter two require the corresponding package to +be installed. } \note{ This function requires R version 4.0.0 or later to utilise the per-user -config directory accessor function. For older R versions, please set the attribute -directly when creating the \code{tiledb_array} object, or via the +config directory accessor function. For older R versions, please set the +attribute directly when creating the \code{tiledb_array} object, or via the \code{return_as()} method. } diff --git a/man/selected_points-set-tiledb_array-method.Rd b/man/selected_points-set-tiledb_array-method.Rd index 242526b543..d3b7054e77 100644 --- a/man/selected_points-set-tiledb_array-method.Rd +++ b/man/selected_points-set-tiledb_array-method.Rd @@ -22,6 +22,7 @@ The modified \code{tiledb_array} array object A \code{tiledb_array} object can have a range selection for each dimension attribute. This methods sets the selection value for \sQuote{selected_points} which is a list (with one element per dimension) of two-column matrices where -each row describes one pair of minimum and maximum values. Alternatively, the list -can be named with the names providing the match to the corresponding dimension. +each row describes one pair of minimum and maximum values. Alternatively, the +list can be named with the names providing the match to the +corresponding dimension. } diff --git a/man/selected_points-tiledb_array-method.Rd b/man/selected_points-tiledb_array-method.Rd index c0b6107d82..2089e564eb 100644 --- a/man/selected_points-tiledb_array-method.Rd +++ b/man/selected_points-tiledb_array-method.Rd @@ -17,8 +17,9 @@ A list which can contain a vector for each dimension } \description{ A \code{tiledb_array} object can have a range selection for each dimension -attribute. This methods returns the selection value for \sQuote{selected_points} -and returns a list (with one element per dimension) of vectors where -each row describes one selected points. Alternatively, the list -can be named with the names providing the match to the corresponding dimension. +attribute. This methods returns the selection value for +\sQuote{selected_points} and returns a list (with one element per dimension) +of vectors where each row describes one selected points. Alternatively, the +list can be named with the names providing the match to the +corresponding dimension. } diff --git a/man/selected_ranges-set-tiledb_array-method.Rd b/man/selected_ranges-set-tiledb_array-method.Rd index 03cf0fedff..9601fcae79 100644 --- a/man/selected_ranges-set-tiledb_array-method.Rd +++ b/man/selected_ranges-set-tiledb_array-method.Rd @@ -13,8 +13,8 @@ selected_ranges(x) <- value \item{x}{A \code{tiledb_array} object} \item{value}{A list of two-column matrices where each list element \sQuote{i} -corresponds to the dimension attribute \sQuote{i}. The matrices can contain rows -where each row contains the minimum and maximum value of a range.} +corresponds to the dimension attribute \sQuote{i}. The matrices can contain +rows where each row contains the minimum and maximum value of a range.} } \value{ The modified \code{tiledb_array} array object @@ -23,6 +23,7 @@ The modified \code{tiledb_array} array object A \code{tiledb_array} object can have a range selection for each dimension attribute. This methods sets the selection value for \sQuote{selected_ranges} which is a list (with one element per dimension) of two-column matrices where -each row describes one pair of minimum and maximum values. Alternatively, the list -can be named with the names providing the match to the corresponding dimension. +each row describes one pair of minimum and maximum values. Alternatively, +the list can be named with the names providing the match to the +corresponding dimension. } diff --git a/man/selected_ranges-tiledb_array-method.Rd b/man/selected_ranges-tiledb_array-method.Rd index acfbf59a5c..e83fe7c584 100644 --- a/man/selected_ranges-tiledb_array-method.Rd +++ b/man/selected_ranges-tiledb_array-method.Rd @@ -17,8 +17,9 @@ A list which can contain a matrix for each dimension } \description{ A \code{tiledb_array} object can have a range selection for each dimension -attribute. This methods returns the selection value for \sQuote{selected_ranges} -and returns a list (with one element per dimension) of two-column matrices where -each row describes one pair of minimum and maximum values. Alternatively, the list -can be named with the names providing the match to the corresponding dimension. +attribute. This methods returns the selection value for +\sQuote{selected_ranges} and returns a list (with one element per dimension) +of two-column matrices where each row describes one pair of minimum and +maximum values. Alternatively, the list can be named with the names providing +the match to the corresponding dimension. } diff --git a/man/show-tiledb_config-method.Rd b/man/show-tiledb_config-method.Rd index 14097091b7..d4c889d9bc 100644 --- a/man/show-tiledb_config-method.Rd +++ b/man/show-tiledb_config-method.Rd @@ -13,7 +13,9 @@ Prints the config object to STDOUT } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} cfg <- tiledb_config() show(cfg) } diff --git a/man/strings_as_factors-set-tiledb_array-method.Rd b/man/strings_as_factors-set-tiledb_array-method.Rd index f0671d875d..c954383408 100644 --- a/man/strings_as_factors-set-tiledb_array-method.Rd +++ b/man/strings_as_factors-set-tiledb_array-method.Rd @@ -18,6 +18,7 @@ strings_as_factors(x) <- value The modified \code{tiledb_array} array object } \description{ -A \code{tiledb_array} object containing character column can have those converted to -factors variables. This methods sets the selection value for \sQuote{strings_as_factors}. +A \code{tiledb_array} object containing character column can have those +converted to factors variables. This methods sets the selection value for +\sQuote{strings_as_factors}. } diff --git a/man/strings_as_factors-tiledb_array-method.Rd b/man/strings_as_factors-tiledb_array-method.Rd index 67b7d2036f..238a89bd11 100644 --- a/man/strings_as_factors-tiledb_array-method.Rd +++ b/man/strings_as_factors-tiledb_array-method.Rd @@ -13,9 +13,11 @@ strings_as_factors(object) \item{object}{A \code{tiledb_array} object} } \value{ -A logical value indicating whether an \code{strings_as_factors} return is selected +A logical value indicating whether an \code{strings_as_factors} +return is selected } \description{ -A \code{tiledb_array} object containing character column can have those converted to -factors variables. This methods returns the selection value for \sQuote{strings_as_factors}. +A \code{tiledb_array} object containing character column can have those +converted to factors variables. This methods returns the selection value +for \sQuote{strings_as_factors}. } diff --git a/man/sub-tiledb_array-ANY-method.Rd b/man/sub-tiledb_array-ANY-method.Rd index d132cec1b2..3b5c6266f2 100644 --- a/man/sub-tiledb_array-ANY-method.Rd +++ b/man/sub-tiledb_array-ANY-method.Rd @@ -13,17 +13,18 @@ \arguments{ \item{x}{tiledb_array object} -\item{i}{optional row index expression which can be a list in which case minimum and maximum -of each list element determine a range; multiple list elements can be used to supply multiple -ranges.} +\item{i}{optional row index expression which can be a list in which case +minimum and maximum of each list element determine a range; multiple list +elements can be used to supply multiple ranges.} -\item{j}{optional column index expression which can be a list in which case minimum and maximum -of each list element determine a range; multiple list elements can be used to supply multiple -ranges.} +\item{j}{optional column index expression which can be a list in which case +minimum and maximum of each list element determine a range; multiple list +elements can be used to supply multiple ranges.} \item{...}{Extra parameters for method signature, currently unused.} -\item{drop}{Optional logical switch to drop dimensions, default FALSE, currently unused.} +\item{drop}{Optional logical switch to drop dimensions, default FALSE, +currently unused.} } \value{ The resulting elements in the selected format diff --git a/man/sub-tiledb_config-ANY-method.Rd b/man/sub-tiledb_config-ANY-method.Rd index 71c40d009f..6f8531345c 100644 --- a/man/sub-tiledb_config-ANY-method.Rd +++ b/man/sub-tiledb_config-ANY-method.Rd @@ -28,7 +28,9 @@ a config string value if parameter exists, else NA Gets a config parameter value } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} cfg <- tiledb_config() cfg["sm.tile_cache_size"] cfg["does_not_exist"] diff --git a/man/sub-tiledb_filter_list-ANY-method.Rd b/man/sub-tiledb_filter_list-ANY-method.Rd index 4348249696..6fe405f4a4 100644 --- a/man/sub-tiledb_filter_list-ANY-method.Rd +++ b/man/sub-tiledb_filter_list-ANY-method.Rd @@ -28,7 +28,9 @@ object tiledb_filter Returns the filter at given index } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} flt <- tiledb_filter("ZSTD") tiledb_filter_set_option(flt, "COMPRESSION_LEVEL", 5) filter_list <- tiledb_filter_list(c(flt)) diff --git a/man/subset-tiledb_array-ANY-ANY-ANY-method.Rd b/man/subset-tiledb_array-ANY-ANY-ANY-method.Rd index c9681b6c55..4e8de8e616 100644 --- a/man/subset-tiledb_array-ANY-ANY-ANY-method.Rd +++ b/man/subset-tiledb_array-ANY-ANY-ANY-method.Rd @@ -37,15 +37,17 @@ This function may still still change; the current implementation should be considered as an initial draft. } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} \dontrun{ -uri <- "quickstart_sparse" ## as created by the other example -arr <- tiledb_array(uri) ## open array -df <- arr[] ## read current content +uri <- "quickstart_sparse" ## as created by the other example +arr <- tiledb_array(uri) ## open array +df <- arr[] ## read current content ## First approach: matching data.frame with appriate row and column -newdf <- data.frame(rows=c(1,2,2), cols=c(1,3,4), a=df$a+100) +newdf <- data.frame(rows = c(1, 2, 2), cols = c(1, 3, 4), a = df$a + 100) ## Second approach: supply indices explicitly -arr[c(1,2), c(1,3)] <- c(42,43) ## two values -arr[2, 4] <- 88 ## or just one +arr[c(1, 2), c(1, 3)] <- c(42, 43) ## two values +arr[2, 4] <- 88 ## or just one } } diff --git a/man/subset-tiledb_config-ANY-ANY-ANY-method.Rd b/man/subset-tiledb_config-ANY-ANY-ANY-method.Rd index 637bdfa33f..3b3685e6ba 100644 --- a/man/subset-tiledb_config-ANY-ANY-ANY-method.Rd +++ b/man/subset-tiledb_config-ANY-ANY-ANY-method.Rd @@ -26,7 +26,9 @@ updated \code{tiledb_config} object Sets a config parameter value } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} cfg <- tiledb_config() cfg["sm.tile_cache_size"] diff --git a/man/tdb_collect-tiledb_array-method.Rd b/man/tdb_collect-tiledb_array-method.Rd index 65ab982d2c..a69bf01f63 100644 --- a/man/tdb_collect-tiledb_array-method.Rd +++ b/man/tdb_collect-tiledb_array-method.Rd @@ -12,8 +12,9 @@ \item{...}{Ignored} } \value{ -The object returning from a tiledb_array query (the type of which can be -set via the return preference mechanism, see the help for \code{"["} accessor) +The object returning from a tiledb_array query (the type of which +can be set via the return preference mechanism, see the help for +\code{"["} accessor) } \description{ Collect the query results to finalize piped expression diff --git a/man/tdb_filter-tiledb_array-method.Rd b/man/tdb_filter-tiledb_array-method.Rd index bd2fe14410..d465cd56f2 100644 --- a/man/tdb_filter-tiledb_array-method.Rd +++ b/man/tdb_filter-tiledb_array-method.Rd @@ -11,8 +11,9 @@ \item{...}{One or more expressions that are parsed as query_condition objects} -\item{strict}{A boolean toogle to, if set, errors if a non-existing attribute is selected -or filtered on, defaults to 'TRUE'; if 'FALSE' a warning is shown by execution proceeds.} +\item{strict}{A boolean toogle to, if set, errors if a non-existing attribute +is selected or filtered on, defaults to 'TRUE'; if 'FALSE' a warning is shown +by execution proceeds.} } \value{ The tiledb_array object, permitting piping diff --git a/man/tile-tiledb_dim-method.Rd b/man/tile-tiledb_dim-method.Rd index a2721fc48e..3789607e96 100644 --- a/man/tile-tiledb_dim-method.Rd +++ b/man/tile-tiledb_dim-method.Rd @@ -16,7 +16,9 @@ a scalar tile extent Return the \code{tiledb_dim} tile extent } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} d1 <- tiledb_dim("d1", domain = c(5L, 10L), tile = 2L) tile(d1) diff --git a/man/tiledb_array-class.Rd b/man/tiledb_array-class.Rd index 184a90f577..770fec15ae 100644 --- a/man/tiledb_array-class.Rd +++ b/man/tiledb_array-class.Rd @@ -18,12 +18,13 @@ based on a refactored implementation utilising newer TileDB features. \item{\code{is.sparse}}{A logical value whether the array is sparse or not} -\item{\code{attrs}}{A character vector to select particular column \sQuote{attributes}; -default is an empty character vector implying \sQuote{all} columns, the special -value \code{NA_character_} has the opposite effect and selects \sQuote{none}.} +\item{\code{attrs}}{A character vector to select particular column +\sQuote{attributes}; default is an empty character vector implying +\sQuote{all} columns, the special value \code{NA_character_} has the opposite +effect and selects \sQuote{none}.} -\item{\code{extended}}{A logical value, defaults to \code{TRUE}, indicating whether index -columns are returned as well.} +\item{\code{extended}}{A logical value, defaults to \code{TRUE}, indicating whether +index columns are returned as well.} \item{\code{selected_ranges}}{An optional list with matrices where each matrix i describes the (min,max) pair of ranges for dimension i} @@ -39,30 +40,36 @@ describes the selected points for dimension i} \item{\code{query_condition}}{A Query Condition object} -\item{\code{timestamp_start}}{A POSIXct datetime variable for the inclusive interval start} +\item{\code{timestamp_start}}{A POSIXct datetime variable for the inclusive +interval start} -\item{\code{timestamp_end}}{A POSIXct datetime variable for the inclusive interval start} +\item{\code{timestamp_end}}{A POSIXct datetime variable for the inclusive +interval start} -\item{\code{return_as}}{A character value with the desired \code{tiledb_array} conversion, -permitted values are \sQuote{asis} (default, returning a list of columns), -\sQuote{array}, \sQuote{matrix},\sQuote{data.frame}, \sQuote{data.table} -\sQuote{tibble}, \sQuote{arrow_table} or \sQuote{arrow} (where the last two are synomyms); -note that \sQuote{data.table}, \sQuote{tibble} and \sQuote{arrow} require the respective -packages to installed.} +\item{\code{return_as}}{A character value with the desired \code{tiledb_array} +conversion, permitted values are \sQuote{asis} (default, returning a list +of columns), \sQuote{array}, \sQuote{matrix},\sQuote{data.frame}, +\sQuote{data.table} \sQuote{tibble}, \sQuote{arrow_table} or \sQuote{arrow} +(where the last two are synomyms); note that \sQuote{data.table}, +\sQuote{tibble} and \sQuote{arrow} require the respective packages +to be installed.} -\item{\code{query_statistics}}{A logical value, defaults to \sQuote{FALSE}; if \sQuote{TRUE} the -query statistics are returned (as a JSON string) via the attribute -\sQuote{query_statistics} of the return object.} +\item{\code{query_statistics}}{A logical value, defaults to \sQuote{FALSE}; if +\sQuote{TRUE} the query statistics are returned (as a JSON string) via the +attribute \sQuote{query_statistics} of the return object.} -\item{\code{sil}}{An optional and internal list object with schema information, used for -parsing queries.} +\item{\code{sil}}{An optional and internal list object with schema information, used +for parsing queries.} -\item{\code{dumpbuffers}}{An optional character variable with a directory name (relative to -\code{/dev/shm}) for writing out results buffers (for internal use / testing)} +\item{\code{dumpbuffers}}{An optional character variable with a directory name +(relative to \code{/dev/shm}) for writing out results buffers (for internal +use / testing)} -\item{\code{buffers}}{An optional list with full pathnames of shared memory buffers to read data from} +\item{\code{buffers}}{An optional list with full pathnames of shared memory buffers +to read data from} -\item{\code{strings_as_factors}}{An optional logical to convert character columns to factor type} +\item{\code{strings_as_factors}}{An optional logical to convert character columns to +factor type} \item{\code{keep_open}}{An optional logical to not close after read or write} diff --git a/man/tiledb_array.Rd b/man/tiledb_array.Rd index 5b2668a9ed..3de738415a 100644 --- a/man/tiledb_array.Rd +++ b/man/tiledb_array.Rd @@ -40,7 +40,8 @@ tiledb_sparse(...) \item{query_type}{optionally loads the array in "READ" or "WRITE" only modes.} -\item{is.sparse}{optional logical switch, defaults to "NA" letting array determine it} +\item{is.sparse}{optional logical switch, defaults to "NA" +letting array determine it} \item{attrs}{optional character vector to select attributes, default is empty implying all are selected, the special value \code{NA_character_} @@ -58,50 +59,59 @@ describes the points selected in dimension i} \item{query_layout}{optional A value for the TileDB query layout, defaults to an empty character variable indicating no special layout is set} -\item{datetimes_as_int64}{optional A logical value selecting date and datetime value -representation as \sQuote{raw} \code{integer64} and not as \code{Date}, -\code{POSIXct} or \code{nanotime} objects.} +\item{datetimes_as_int64}{optional A logical value selecting date and +datetime value representation as \sQuote{raw} \code{integer64} and not as +\code{Date}, \code{POSIXct} or \code{nanotime} objects.} -\item{encryption_key}{optional A character value with an AES-256 encryption key -in case the array was written with encryption.} +\item{encryption_key}{optional A character value with an AES-256 encryption +key in case the array was written with encryption.} -\item{query_condition}{optional \code{tiledb_query_condition} object, by default uninitialized -without a condition; this functionality requires TileDB 2.3.0 or later} +\item{query_condition}{optional \code{tiledb_query_condition} object, by +default uninitialized without a condition; this functionality requires +TileDB 2.3.0 or later} -\item{timestamp_start}{optional A POSIXct Datetime value determining the inclusive time point -at which the array is to be openened. No fragments written earlier will be considered.} +\item{timestamp_start}{optional A POSIXct Datetime value determining the +inclusive time point at which the array is to be openened. No fragments +written earlier will be considered.} -\item{timestamp_end}{optional A POSIXct Datetime value determining the inclusive time point -until which the array is to be openened. No fragments written earlier later be considered.} +\item{timestamp_end}{optional A POSIXct Datetime value determining the +inclusive time point until which the array is to be openened. No fragments +written earlier later be considered.} -\item{return_as}{optional A character value with the desired \code{tiledb_array} conversion, -permitted values are \sQuote{asis} (default, returning a list of columns), \sQuote{array}, -\sQuote{matrix},\sQuote{data.frame}, \sQuote{data.table}, \sQuote{tibble}, \sQuote{arrow_table}, -or \sQuote{arrow} (as an alias for \sQuote{arrow_table}; here \sQuote{data.table}, -\sQuote{tibble} and \sQuote{arrow} require the respective packages to be installed. +\item{return_as}{optional A character value with the desired +\code{tiledb_array} conversion, permitted values are \sQuote{asis} (default, +returning a list of columns), \sQuote{array}, \sQuote{matrix}, +\sQuote{data.frame}, \sQuote{data.table}, \sQuote{tibble}, +\sQuote{arrow_table}, or \sQuote{arrow} (as an alias for +\sQuote{arrow_table}; here \sQuote{data.table}, \sQuote{tibble} and +\sQuote{arrow} require the respective packages to be installed. The existing \code{as.*} arguments take precedent over this.} -\item{query_statistics}{optional A logical value, defaults to \sQuote{FALSE}; if \sQuote{TRUE} the -query statistics are returned (as a JSON string) via the attribute -\sQuote{query_statistics} of the return object.} +\item{query_statistics}{optional A logical value, defaults to \sQuote{FALSE}; +if \sQuote{TRUE} the query statistics are returned (as a JSON string) via +the attribute \sQuote{query_statistics} of the return object.} -\item{strings_as_factors}{An optional logical to convert character columns to factor type; defaults -to the value of \code{getOption("stringsAsFactors", FALSE)}.} +\item{strings_as_factors}{An optional logical to convert character columns to +factor type; defaults to the value of +\code{getOption("stringsAsFactors", FALSE)}.} \item{keep_open}{An optional logical to not close after read or write} -\item{sil}{optional A list, by default empty to store schema information when query objects are -parsed.} +\item{sil}{optional A list, by default empty to store schema information +when query objects are parsed.} -\item{dumpbuffers}{An optional character variable with a directory name (relative to -\code{/dev/shm}) for writing out results buffers (for internal use / testing)} +\item{dumpbuffers}{An optional character variable with a directory name +(relative to \code{/dev/shm}) for writing out results buffers (for +internal use / testing)} -\item{buffers}{An optional list with full pathnames of shared memory buffers to read data from} +\item{buffers}{An optional list with full pathnames of shared memory buffers +to read data from} \item{ctx}{optional tiledb_ctx} -\item{as.data.frame}{An optional deprecated alternative to \code{return_as="data.frame"} which has -been deprecated and removed, but is still used in one BioConductor package; this argument will be removed +\item{as.data.frame}{An optional deprecated alternative to +\code{return_as="data.frame"} which has been deprecated and removed, but is +still used in one BioConductor package; this argument will be removed once the updated package has been released.} \item{...}{Used as a pass-through for \code{tiledb_dense} diff --git a/man/tiledb_array_create.Rd b/man/tiledb_array_create.Rd index 2233f8d821..eb795e0fa3 100644 --- a/man/tiledb_array_create.Rd +++ b/man/tiledb_array_create.Rd @@ -18,7 +18,9 @@ in case the array should be encryption.} Creates a new TileDB array given an input schema. } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} \dontrun{ pth <- tempdir() dom <- tiledb_domain(dims = c(tiledb_dim("d1", c(1L, 10L), type = "INT32"))) diff --git a/man/tiledb_array_delete_fragments_list.Rd b/man/tiledb_array_delete_fragments_list.Rd index dbf60303b3..e738469cdb 100644 --- a/man/tiledb_array_delete_fragments_list.Rd +++ b/man/tiledb_array_delete_fragments_list.Rd @@ -7,7 +7,8 @@ tiledb_array_delete_fragments_list(arr, fragments, ctx = tiledb_get_context()) } \arguments{ -\item{arr}{A TileDB Array object as for example returned by \code{tiledb_array()}} +\item{arr}{A TileDB Array object as for example returned by +\code{tiledb_array()}} \item{fragments}{A character vector with fragment URIs} diff --git a/man/tiledb_array_get_non_empty_domain_from_index.Rd b/man/tiledb_array_get_non_empty_domain_from_index.Rd index 7e760cb3c3..af7b67ebe6 100644 --- a/man/tiledb_array_get_non_empty_domain_from_index.Rd +++ b/man/tiledb_array_get_non_empty_domain_from_index.Rd @@ -14,9 +14,9 @@ tiledb_array_get_non_empty_domain_from_index(arr, idx) \value{ A two-element object is returned describing the domain of selected dimension; it will either be a numeric vector in case of a fixed-size -fixed-sized dimensions, or a characer vector for a variable-sized one. +fixed-sized dimensions, or a character vector for a variable-sized one. } \description{ -This functions works for both fixed- and variable-sized dimensions and switches -internally. +This functions works for both fixed- and variable-sized dimensions and +switches internally. } diff --git a/man/tiledb_array_get_non_empty_domain_from_name.Rd b/man/tiledb_array_get_non_empty_domain_from_name.Rd index efb0cdcd20..d599ec9167 100644 --- a/man/tiledb_array_get_non_empty_domain_from_name.Rd +++ b/man/tiledb_array_get_non_empty_domain_from_name.Rd @@ -14,9 +14,9 @@ tiledb_array_get_non_empty_domain_from_name(arr, name) \value{ A two-element object is returned describing the domain of selected dimension; it will either be a numeric vector in case of a fixed-size -fixed-sized dimensions, or a characer vector for a variable-sized one. +fixed-sized dimensions, or a character vector for a variable-sized one. } \description{ -This functions works for both fixed- and variable-sized dimensions and switches -internally. +This functions works for both fixed- and variable-sized dimensions and +switches internally. } diff --git a/man/tiledb_array_open.Rd b/man/tiledb_array_open.Rd index 7eb50eecf8..be57540dee 100644 --- a/man/tiledb_array_open.Rd +++ b/man/tiledb_array_open.Rd @@ -6,8 +6,12 @@ \usage{ tiledb_array_open( arr, - type = if (tiledb_version(TRUE) >= "2.12.0") c("READ", "WRITE", "DELETE", - "MODIFY_EXCLUSIVE") else c("READ", "WRITE") + type = if (tiledb_version(TRUE) >= "2.12.0") { + c("READ", "WRITE", "DELETE", + "MODIFY_EXCLUSIVE") + } else { + c("READ", "WRITE") + } ) } \arguments{ diff --git a/man/tiledb_array_schema.Rd b/man/tiledb_array_schema.Rd index b6aea7c851..72a05baa85 100644 --- a/man/tiledb_array_schema.Rd +++ b/man/tiledb_array_schema.Rd @@ -48,15 +48,21 @@ tiledb_array_schema( Constructs a \code{tiledb_array_schema} object } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} schema <- tiledb_array_schema( - dom = tiledb_domain( - dims = c(tiledb_dim("rows", c(1L, 4L), 4L, "INT32"), - tiledb_dim("cols", c(1L, 4L), 4L, "INT32"))), - attrs = c(tiledb_attr("a", type = "INT32")), - cell_order = "COL_MAJOR", - tile_order = "COL_MAJOR", - sparse = FALSE) + dom = tiledb_domain( + dims = c( + tiledb_dim("rows", c(1L, 4L), 4L, "INT32"), + tiledb_dim("cols", c(1L, 4L), 4L, "INT32") + ) + ), + attrs = c(tiledb_attr("a", type = "INT32")), + cell_order = "COL_MAJOR", + tile_order = "COL_MAJOR", + sparse = FALSE +) schema } diff --git a/man/tiledb_attr.Rd b/man/tiledb_attr.Rd index 6332e06451..ae8f0358b5 100644 --- a/man/tiledb_attr.Rd +++ b/man/tiledb_attr.Rd @@ -38,10 +38,14 @@ values} Constructs a \code{tiledb_attr} object } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} flt <- tiledb_filter_list(list(tiledb_filter("GZIP"))) -attr <- tiledb_attr(name = "a1", type = "INT32", - filter_list = flt) +attr <- tiledb_attr( + name = "a1", type = "INT32", + filter_list = flt +) attr } diff --git a/man/tiledb_attribute_get_cell_val_num.Rd b/man/tiledb_attribute_get_cell_val_num.Rd index 24ea8c2cf0..7a139afd0e 100644 --- a/man/tiledb_attribute_get_cell_val_num.Rd +++ b/man/tiledb_attribute_get_cell_val_num.Rd @@ -22,7 +22,9 @@ integer number of cells Return the number of scalar values per attribute cell } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} a1 <- tiledb_attr("a1", type = "FLOAT64", ncells = 1) cell_val_num(a1) } diff --git a/man/tiledb_config.Rd b/man/tiledb_config.Rd index c42d5e77c4..d49d28b211 100644 --- a/man/tiledb_config.Rd +++ b/man/tiledb_config.Rd @@ -21,7 +21,9 @@ of the of the \code{tiledb_ctx} object. Examples for this are create a context object, and \code{cfg <- config(ctx)} to retrieve it. } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} cfg <- tiledb_config() cfg["sm.tile_cache_size"] diff --git a/man/tiledb_config_as_built_json.Rd b/man/tiledb_config_as_built_json.Rd index 5d78bb7bdd..4bb03b763a 100644 --- a/man/tiledb_config_as_built_json.Rd +++ b/man/tiledb_config_as_built_json.Rd @@ -13,8 +13,9 @@ The JSON string containing 'AsBuilt' information Return the 'AsBuilt' JSON string } \examples{ -if (tiledb_version(TRUE) > "2.17") - txt <- tiledb::tiledb_config_as_built_json() +if (tiledb_version(TRUE) > "2.17") { + txt <- tiledb::tiledb_config_as_built_json() +} ## now eg either one of ## sapply(jsonlite::fromJSON(txt)$as_built$parameters$storage_backends, \(x) x[[1]]) ## sapply(RcppSimdJson::fparse(txt)$as_built$parameters$storage_backends, \(x) x[[1]]) diff --git a/man/tiledb_config_load.Rd b/man/tiledb_config_load.Rd index ffdc296b2b..1fc998f959 100644 --- a/man/tiledb_config_load.Rd +++ b/man/tiledb_config_load.Rd @@ -13,7 +13,9 @@ tiledb_config_load(path) Load a saved \code{tiledb_config} file from disk } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} tmp <- tempfile() cfg <- tiledb_config(c("sm.tile_cache_size" = "10")) pth <- tiledb_config_save(cfg, tmp) diff --git a/man/tiledb_config_save.Rd b/man/tiledb_config_save.Rd index 365e3968e7..158000da24 100644 --- a/man/tiledb_config_save.Rd +++ b/man/tiledb_config_save.Rd @@ -18,7 +18,9 @@ path to created config file Save a \code{tiledb_config} object ot a local text file } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} tmp <- tempfile() cfg <- tiledb_config(c("sm.tile_cache_size" = "10")) pth <- tiledb_config_save(cfg, tmp) diff --git a/man/tiledb_ctx.Rd b/man/tiledb_ctx.Rd index 4670b81356..3e7eed3085 100644 --- a/man/tiledb_ctx.Rd +++ b/man/tiledb_ctx.Rd @@ -18,7 +18,9 @@ tiledb_ctx(config = NULL, cached = TRUE) Creates a \code{tiledb_ctx} object } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} # default configuration ctx <- tiledb_ctx() diff --git a/man/tiledb_ctx_set_tag.Rd b/man/tiledb_ctx_set_tag.Rd index ec1ec5ba9d..587d3fe33e 100644 --- a/man/tiledb_ctx_set_tag.Rd +++ b/man/tiledb_ctx_set_tag.Rd @@ -17,7 +17,9 @@ tiledb_ctx_set_tag(object, key, value) Sets a string:string "tag" on the Ctx } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} ctx <- tiledb_ctx(c("sm.tile_cache_size" = "10")) cfg <- tiledb_ctx_set_tag(ctx, "tag", "value") diff --git a/man/tiledb_current_domain.Rd b/man/tiledb_current_domain.Rd index 510fc84788..0d2cf33f2c 100644 --- a/man/tiledb_current_domain.Rd +++ b/man/tiledb_current_domain.Rd @@ -16,9 +16,11 @@ The \code{tiledb_current_domain} object Creates a \code{tiledb_current_domain} object } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} if (tiledb_version(TRUE) >= "2.25.0") { - cd <-tiledb_current_domain() + cd <- tiledb_current_domain() } } diff --git a/man/tiledb_dim.Rd b/man/tiledb_dim.Rd index 0df5f01968..f8908c1904 100644 --- a/man/tiledb_dim.Rd +++ b/man/tiledb_dim.Rd @@ -37,7 +37,9 @@ is no filter} Constructs a \code{tiledb_dim} object } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} tiledb_dim(name = "d1", domain = c(1L, 10L), tile = 5L, type = "INT32") } diff --git a/man/tiledb_domain.Rd b/man/tiledb_domain.Rd index 91221add36..fee1726f06 100644 --- a/man/tiledb_domain.Rd +++ b/man/tiledb_domain.Rd @@ -18,7 +18,11 @@ tiledb_domain All \code{tiledb_dim} must be of the same TileDB type. } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} -dom <- tiledb_domain(dims = c(tiledb_dim("d1", c(1L, 100L), type = "INT32"), - tiledb_dim("d2", c(1L, 50L), type = "INT32"))) +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} +dom <- tiledb_domain(dims = c( + tiledb_dim("d1", c(1L, 100L), type = "INT32"), + tiledb_dim("d2", c(1L, 50L), type = "INT32") +)) } diff --git a/man/tiledb_filter.Rd b/man/tiledb_filter.Rd index 1a1a74f128..4c8761be48 100644 --- a/man/tiledb_filter.Rd +++ b/man/tiledb_filter.Rd @@ -40,7 +40,9 @@ Valid compression options vary depending on the filter used, consult the TileDB docs for more information. } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} tiledb_filter("ZSTD") } diff --git a/man/tiledb_filter_get_option.Rd b/man/tiledb_filter_get_option.Rd index 5bb9b59b82..b410e0de4b 100644 --- a/man/tiledb_filter_get_option.Rd +++ b/man/tiledb_filter_get_option.Rd @@ -18,9 +18,11 @@ Integer value Returns the filter's option } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} c <- tiledb_filter("ZSTD") -tiledb_filter_set_option(c,"COMPRESSION_LEVEL", 5) +tiledb_filter_set_option(c, "COMPRESSION_LEVEL", 5) tiledb_filter_get_option(c, "COMPRESSION_LEVEL") } diff --git a/man/tiledb_filter_list.Rd b/man/tiledb_filter_list.Rd index 6e8b314507..a17bd1ca5b 100644 --- a/man/tiledb_filter_list.Rd +++ b/man/tiledb_filter_list.Rd @@ -18,7 +18,9 @@ tiledb_filter_list object Constructs a \code{tiledb_filter_list} object } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} flt <- tiledb_filter("ZSTD") tiledb_filter_set_option(flt, "COMPRESSION_LEVEL", 5) filter_list <- tiledb_filter_list(c(flt)) diff --git a/man/tiledb_filter_list_get_max_chunk_size.Rd b/man/tiledb_filter_list_get_max_chunk_size.Rd index e930664e8b..d5fb8f0dda 100644 --- a/man/tiledb_filter_list_get_max_chunk_size.Rd +++ b/man/tiledb_filter_list_get_max_chunk_size.Rd @@ -22,7 +22,9 @@ integer max_chunk_size Returns the filter_list's max_chunk_size } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} flt <- tiledb_filter("ZSTD") tiledb_filter_set_option(flt, "COMPRESSION_LEVEL", 5) filter_list <- tiledb_filter_list(c(flt)) diff --git a/man/tiledb_filter_list_set_max_chunk_size.Rd b/man/tiledb_filter_list_set_max_chunk_size.Rd index cac45bc55f..976e6def94 100644 --- a/man/tiledb_filter_list_set_max_chunk_size.Rd +++ b/man/tiledb_filter_list_set_max_chunk_size.Rd @@ -21,7 +21,9 @@ tiledb_filter_list_set_max_chunk_size(object, value) Set the filter_list's max_chunk_size } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} flt <- tiledb_filter("ZSTD") tiledb_filter_set_option(flt, "COMPRESSION_LEVEL", 5) filter_list <- tiledb_filter_list(c(flt)) diff --git a/man/tiledb_filter_set_option.Rd b/man/tiledb_filter_set_option.Rd index ffa6ff1105..7c7bbea6bc 100644 --- a/man/tiledb_filter_set_option.Rd +++ b/man/tiledb_filter_set_option.Rd @@ -20,8 +20,10 @@ The modified filter object is returned. Set the option for a filter } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} c <- tiledb_filter("ZSTD") -tiledb_filter_set_option(c,"COMPRESSION_LEVEL", 5) +tiledb_filter_set_option(c, "COMPRESSION_LEVEL", 5) tiledb_filter_get_option(c, "COMPRESSION_LEVEL") } diff --git a/man/tiledb_filter_type.Rd b/man/tiledb_filter_type.Rd index 064e1ba3f7..7998edd5a9 100644 --- a/man/tiledb_filter_type.Rd +++ b/man/tiledb_filter_type.Rd @@ -16,7 +16,9 @@ TileDB filter type string Returns the type of the filter used } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} c <- tiledb_filter("ZSTD") tiledb_filter_type(c) diff --git a/man/tiledb_group.Rd b/man/tiledb_group.Rd index 7db77de6ed..8953d08148 100644 --- a/man/tiledb_group.Rd +++ b/man/tiledb_group.Rd @@ -14,8 +14,8 @@ tiledb_group( \arguments{ \item{uri}{Character variable with the URI of the new group object} -\item{type}{Character variable with the query type value: one of \dQuote{READ} -or \dQuote{WRITE}} +\item{type}{Character variable with the query type value: one of +\dQuote{READ} or \dQuote{WRITE}} \item{ctx}{(optional) A TileDB Context object; if not supplied the default context object is retrieved} diff --git a/man/tiledb_group_add_member.Rd b/man/tiledb_group_add_member.Rd index b683d9870e..0b218bff63 100644 --- a/man/tiledb_group_add_member.Rd +++ b/man/tiledb_group_add_member.Rd @@ -7,13 +7,16 @@ tiledb_group_add_member(grp, uri, relative, name = NULL) } \arguments{ -\item{grp}{A TileDB Group object as for example returned by \code{tiledb_group()}} +\item{grp}{A TileDB Group object as for example returned by +\code{tiledb_group()}} \item{uri}{A character value with a new URI} -\item{relative}{A logical value indicating whether URI is relative to the group} +\item{relative}{A logical value indicating whether URI is +relative to the group} -\item{name}{An optional character providing a name for the object, defaults to \code{NULL}} +\item{name}{An optional character providing a name for the +object, defaults to \code{NULL}} } \value{ The TileDB Group object, invisibly diff --git a/man/tiledb_group_close.Rd b/man/tiledb_group_close.Rd index abeccb8ffa..bd53627501 100644 --- a/man/tiledb_group_close.Rd +++ b/man/tiledb_group_close.Rd @@ -7,7 +7,8 @@ tiledb_group_close(grp) } \arguments{ -\item{grp}{A TileDB Group object as for example returned by \code{tiledb_group()}} +\item{grp}{A TileDB Group object as for example returned by +\code{tiledb_group()}} } \value{ The TileDB Group object but closed for reading or writing diff --git a/man/tiledb_group_create.Rd b/man/tiledb_group_create.Rd index f1df01aa33..abe1bcff0b 100644 --- a/man/tiledb_group_create.Rd +++ b/man/tiledb_group_create.Rd @@ -19,7 +19,9 @@ The uri path, invisibly Create a TileDB Group at the given path } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} \dontrun{ pth <- tempdir() tiledb_group_create(pth) diff --git a/man/tiledb_group_delete.Rd b/man/tiledb_group_delete.Rd index aadf775049..9c3b91e041 100644 --- a/man/tiledb_group_delete.Rd +++ b/man/tiledb_group_delete.Rd @@ -7,18 +7,19 @@ tiledb_group_delete(grp, uri, recursive = FALSE) } \arguments{ -\item{grp}{A TileDB Group object as for example returned by \code{tiledb_group()}} +\item{grp}{A TileDB Group object as for example returned by +\code{tiledb_group()}} \item{uri}{Character variable with the URI of the group item to be deleted} -\item{recursive}{A logical value indicating whether all data iniside the -group is to be delet} +\item{recursive}{A logical value indicating whether all data inside the +group is to be deleted} } \value{ Nothing is returned, the function is invoked for the side-effect of group data removal. } \description{ -The group must be opened in \sQuote{MODIFY_EXCLUSIVE} mode, otherwise the function -will error out. +The group must be opened in \sQuote{MODIFY_EXCLUSIVE} mode, otherwise +the function will error out. } diff --git a/man/tiledb_group_delete_metadata.Rd b/man/tiledb_group_delete_metadata.Rd index 4f86804688..6313d44ddc 100644 --- a/man/tiledb_group_delete_metadata.Rd +++ b/man/tiledb_group_delete_metadata.Rd @@ -7,9 +7,11 @@ tiledb_group_delete_metadata(grp, key) } \arguments{ -\item{grp}{A TileDB Group object as for example returned by \code{tiledb_group()}} +\item{grp}{A TileDB Group object as for example returned by +\code{tiledb_group()}} -\item{key}{A character value with they index under which the data will be written} +\item{key}{A character value with they index under which the +data will be written} } \value{ The TileDB Group object, invisibly diff --git a/man/tiledb_group_get_all_metadata.Rd b/man/tiledb_group_get_all_metadata.Rd index a599a5f84b..b589e2b050 100644 --- a/man/tiledb_group_get_all_metadata.Rd +++ b/man/tiledb_group_get_all_metadata.Rd @@ -7,7 +7,8 @@ tiledb_group_get_all_metadata(grp) } \arguments{ -\item{grp}{A TileDB Group object as for example returned by \code{tiledb_group()}} +\item{grp}{A TileDB Group object as for example returned by +\code{tiledb_group()}} } \value{ A named List with all Metadata objects index diff --git a/man/tiledb_group_get_config.Rd b/man/tiledb_group_get_config.Rd index 461ea67a0d..fdb9435908 100644 --- a/man/tiledb_group_get_config.Rd +++ b/man/tiledb_group_get_config.Rd @@ -7,7 +7,8 @@ tiledb_group_get_config(grp) } \arguments{ -\item{grp}{A TileDB Group object as for example returned by \code{tiledb_group()}} +\item{grp}{A TileDB Group object as for example returned by +\code{tiledb_group()}} } \value{ The TileDB Config object of the TileDB Group object diff --git a/man/tiledb_group_get_metadata.Rd b/man/tiledb_group_get_metadata.Rd index 5d6945d877..726660d0d2 100644 --- a/man/tiledb_group_get_metadata.Rd +++ b/man/tiledb_group_get_metadata.Rd @@ -7,9 +7,11 @@ tiledb_group_get_metadata(grp, key) } \arguments{ -\item{grp}{A TileDB Group object as for example returned by \code{tiledb_group()}} +\item{grp}{A TileDB Group object as for example returned by +\code{tiledb_group()}} -\item{key}{A character value with the key of the metadata object to be retrieved} +\item{key}{A character value with the key of the metadata +object to be retrieved} } \value{ The requested object, or NULL is not found diff --git a/man/tiledb_group_get_metadata_from_index.Rd b/man/tiledb_group_get_metadata_from_index.Rd index 70aa6d7fc5..7c2fd0c9b2 100644 --- a/man/tiledb_group_get_metadata_from_index.Rd +++ b/man/tiledb_group_get_metadata_from_index.Rd @@ -7,7 +7,8 @@ tiledb_group_get_metadata_from_index(grp, idx) } \arguments{ -\item{grp}{A TileDB Group object as for example returned by \code{tiledb_group()}} +\item{grp}{A TileDB Group object as for example returned by +\code{tiledb_group()}} \item{idx}{A numeric value with the index of the metadata object to be retrieved} } diff --git a/man/tiledb_group_has_metadata.Rd b/man/tiledb_group_has_metadata.Rd index cdfe4dbe95..0b2ce3c59d 100644 --- a/man/tiledb_group_has_metadata.Rd +++ b/man/tiledb_group_has_metadata.Rd @@ -7,9 +7,11 @@ tiledb_group_has_metadata(grp, key) } \arguments{ -\item{grp}{A TileDB Group object as for example returned by \code{tiledb_group()}} +\item{grp}{A TileDB Group object as for example returned by +\code{tiledb_group()}} -\item{key}{A character value with they index under which the data will be written} +\item{key}{A character value with they index under which the +data will be written} } \value{ A boolean value indicating with the object is present diff --git a/man/tiledb_group_is_open.Rd b/man/tiledb_group_is_open.Rd index 384cd51e68..91f149f1e4 100644 --- a/man/tiledb_group_is_open.Rd +++ b/man/tiledb_group_is_open.Rd @@ -7,7 +7,8 @@ tiledb_group_is_open(grp) } \arguments{ -\item{grp}{A TileDB Group object as for example returned by \code{tiledb_group()}} +\item{grp}{A TileDB Group object as for example returned by +\code{tiledb_group()}} } \value{ A boolean indicating whether the TileDB Group object is open diff --git a/man/tiledb_group_is_relative.Rd b/man/tiledb_group_is_relative.Rd index 2b51466367..338a5e32a6 100644 --- a/man/tiledb_group_is_relative.Rd +++ b/man/tiledb_group_is_relative.Rd @@ -7,7 +7,8 @@ tiledb_group_is_relative(grp, name) } \arguments{ -\item{grp}{A TileDB Group object as for example returned by \code{tiledb_group()}} +\item{grp}{A TileDB Group object as for example returned by +\code{tiledb_group()}} \item{name}{A character value with a group name} } diff --git a/man/tiledb_group_member.Rd b/man/tiledb_group_member.Rd index db559f1936..8cdf0d43f4 100644 --- a/man/tiledb_group_member.Rd +++ b/man/tiledb_group_member.Rd @@ -7,15 +7,17 @@ tiledb_group_member(grp, idx) } \arguments{ -\item{grp}{A TileDB Group object as for example returned by \code{tiledb_group()}} +\item{grp}{A TileDB Group object as for example returned by +\code{tiledb_group()}} -\item{idx}{A numeric value with the index of the metadata object to be retrieved} +\item{idx}{A numeric value with the index of the metadata +object to be retrieved} } \value{ -A character vector with three elements: the member type, its uri, and name -(or \code{""} if the member is unnamed). +A character vector with three elements: the member +type, its uri, and name (or \code{""} if the member is unnamed). } \description{ -This function returns a three-element character vector with the member object translated to -character, uri, and optional name. +This function returns a three-element character vector with the member +object translated to character, uri, and optional name. } diff --git a/man/tiledb_group_member_count.Rd b/man/tiledb_group_member_count.Rd index 8e3b048bf8..53b8969a5f 100644 --- a/man/tiledb_group_member_count.Rd +++ b/man/tiledb_group_member_count.Rd @@ -7,7 +7,8 @@ tiledb_group_member_count(grp) } \arguments{ -\item{grp}{A TileDB Group object as for example returned by \code{tiledb_group()}} +\item{grp}{A TileDB Group object as for example returned by +\code{tiledb_group()}} } \value{ The Count of Members in the TileDB Group object diff --git a/man/tiledb_group_member_dump.Rd b/man/tiledb_group_member_dump.Rd index 783df6783b..60eebacedd 100644 --- a/man/tiledb_group_member_dump.Rd +++ b/man/tiledb_group_member_dump.Rd @@ -7,11 +7,12 @@ tiledb_group_member_dump(grp, recursive = FALSE) } \arguments{ -\item{grp}{A TileDB Group object as for example returned by \code{tiledb_group()}} +\item{grp}{A TileDB Group object as for example returned by +\code{tiledb_group()}} -\item{recursive}{A logical value indicating whether a recursive dump is desired, defaults -to \sQuote{FALSE}. Note that recursive listings on remote object may be an expensive or -slow operation.} +\item{recursive}{A logical value indicating whether a recursive +dump is desired, defaults to \sQuote{FALSE}. Note that recursive listings +on remote object may be an expensive or slow operation.} } \value{ A character string diff --git a/man/tiledb_group_metadata_num.Rd b/man/tiledb_group_metadata_num.Rd index 7928dba44f..25567d59b8 100644 --- a/man/tiledb_group_metadata_num.Rd +++ b/man/tiledb_group_metadata_num.Rd @@ -7,7 +7,8 @@ tiledb_group_metadata_num(grp) } \arguments{ -\item{grp}{A TileDB Group object as for example returned by \code{tiledb_group()}} +\item{grp}{A TileDB Group object as for example returned by +\code{tiledb_group()}} } \value{ A numeric value with the number of metadata objects diff --git a/man/tiledb_group_open.Rd b/man/tiledb_group_open.Rd index aba8df2de5..55f64587ea 100644 --- a/man/tiledb_group_open.Rd +++ b/man/tiledb_group_open.Rd @@ -7,10 +7,11 @@ tiledb_group_open(grp, type = c("READ", "WRITE", "MODIFY_EXCLUSIVE")) } \arguments{ -\item{grp}{A TileDB Group object as for example returned by \code{tiledb_group()}} +\item{grp}{A TileDB Group object as for example returned by +\code{tiledb_group()}} -\item{type}{A character value that must be either \sQuote{READ}, \sQuote{WRITE} -or \sQuote{MODIFY_EXCLUSIVE}} +\item{type}{A character value that must be either \sQuote{READ}, +\sQuote{WRITE} or \sQuote{MODIFY_EXCLUSIVE}} } \value{ The TileDB Group object but opened for reading or writing diff --git a/man/tiledb_group_put_metadata.Rd b/man/tiledb_group_put_metadata.Rd index cbc39b6dbc..4828b0ca75 100644 --- a/man/tiledb_group_put_metadata.Rd +++ b/man/tiledb_group_put_metadata.Rd @@ -7,9 +7,11 @@ tiledb_group_put_metadata(grp, key, val) } \arguments{ -\item{grp}{A TileDB Group object as for example returned by \code{tiledb_group()}} +\item{grp}{A TileDB Group object as for example returned by +\code{tiledb_group()}} -\item{key}{A character value with they index under which the data will be written} +\item{key}{A character value with they index under which the +data will be written} \item{val}{An R object (numeric, int, or char vector) that will be stored} } diff --git a/man/tiledb_group_query_type.Rd b/man/tiledb_group_query_type.Rd index cc09bd2dc5..3f5d2f5fb0 100644 --- a/man/tiledb_group_query_type.Rd +++ b/man/tiledb_group_query_type.Rd @@ -7,10 +7,12 @@ tiledb_group_query_type(grp) } \arguments{ -\item{grp}{A TileDB Group object as for example returned by \code{tiledb_group()}} +\item{grp}{A TileDB Group object as for example returned by +\code{tiledb_group()}} } \value{ -A character value with the query type i.e. one of \dQuote{READ} or \dQuote{WRITE}. +A character value with the query type i.e. one of +\dQuote{READ} or \dQuote{WRITE}. } \description{ Return a TileDB Group query type diff --git a/man/tiledb_group_remove_member.Rd b/man/tiledb_group_remove_member.Rd index 2dbe9ef3b1..82720976fa 100644 --- a/man/tiledb_group_remove_member.Rd +++ b/man/tiledb_group_remove_member.Rd @@ -7,10 +7,11 @@ tiledb_group_remove_member(grp, uri) } \arguments{ -\item{grp}{A TileDB Group object as for example returned by \code{tiledb_group()}} +\item{grp}{A TileDB Group object as for example returned by +\code{tiledb_group()}} -\item{uri}{A character value with a the URI of the member to be removed, or (if added -with a name) the name of the member} +\item{uri}{A character value with a the URI of the member to +be removed, or (if added with a name) the name of the member} } \value{ The TileDB Group object, invisibly diff --git a/man/tiledb_group_set_config.Rd b/man/tiledb_group_set_config.Rd index 018b075e41..3aa1378727 100644 --- a/man/tiledb_group_set_config.Rd +++ b/man/tiledb_group_set_config.Rd @@ -7,7 +7,8 @@ tiledb_group_set_config(grp, cfg) } \arguments{ -\item{grp}{A TileDB Group object as for example returned by \code{tiledb_group()}} +\item{grp}{A TileDB Group object as for example returned by +\code{tiledb_group()}} \item{cfg}{A TileDB Config object} } diff --git a/man/tiledb_group_uri.Rd b/man/tiledb_group_uri.Rd index 29fd392165..3faf032ade 100644 --- a/man/tiledb_group_uri.Rd +++ b/man/tiledb_group_uri.Rd @@ -7,7 +7,8 @@ tiledb_group_uri(grp) } \arguments{ -\item{grp}{A TileDB Group object as for example returned by \code{tiledb_group()}} +\item{grp}{A TileDB Group object as for example returned by +\code{tiledb_group()}} } \value{ A character value with the URI diff --git a/man/tiledb_is_supported_fs.Rd b/man/tiledb_is_supported_fs.Rd index 10cad11b2a..bd4da11883 100644 --- a/man/tiledb_is_supported_fs.Rd +++ b/man/tiledb_is_supported_fs.Rd @@ -26,7 +26,9 @@ Ex: } } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} tiledb_is_supported_fs("file") tiledb_is_supported_fs("s3") diff --git a/man/tiledb_ndim-tiledb_array_schema-method.Rd b/man/tiledb_ndim-tiledb_array_schema-method.Rd index c79256ef75..f264a982af 100644 --- a/man/tiledb_ndim-tiledb_array_schema-method.Rd +++ b/man/tiledb_ndim-tiledb_array_schema-method.Rd @@ -16,10 +16,14 @@ integer number of dimensions Return the number of dimensions associated with the \code{tiledb_array_schema} } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} dom <- tiledb_domain(dims = c(tiledb_dim("d1", c(1L, 10L), type = "INT32"))) -sch <- tiledb_array_schema(dom, attrs = c(tiledb_attr("a1", type = "INT32"), - tiledb_attr("a2", type = "FLOAT64"))) +sch <- tiledb_array_schema(dom, attrs = c( + tiledb_attr("a1", type = "INT32"), + tiledb_attr("a2", type = "FLOAT64") +)) tiledb_ndim(sch) } diff --git a/man/tiledb_ndim-tiledb_dim-method.Rd b/man/tiledb_ndim-tiledb_dim-method.Rd index 60536de16c..a1827b7cc9 100644 --- a/man/tiledb_ndim-tiledb_dim-method.Rd +++ b/man/tiledb_ndim-tiledb_dim-method.Rd @@ -16,7 +16,9 @@ Returns the number of dimensions for a tiledb domain object } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} d1 <- tiledb_dim("d1", c(1L, 10L), 10L) tiledb_ndim(d1) diff --git a/man/tiledb_ndim-tiledb_domain-method.Rd b/man/tiledb_ndim-tiledb_domain-method.Rd index d492646d18..492eef0192 100644 --- a/man/tiledb_ndim-tiledb_domain-method.Rd +++ b/man/tiledb_ndim-tiledb_domain-method.Rd @@ -16,11 +16,15 @@ integer number of dimensions Returns the number of dimensions of the \code{tiledb_domain} } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} dom <- tiledb_domain(dims = c(tiledb_dim("d1", c(0.5, 100.0), type = "FLOAT64"))) tiledb_ndim(dom) -dom <- tiledb_domain(dims = c(tiledb_dim("d1", c(0.5, 100.0), type = "FLOAT64"), - tiledb_dim("d2", c(0.5, 100.0), type = "FLOAT64"))) +dom <- tiledb_domain(dims = c( + tiledb_dim("d1", c(0.5, 100.0), type = "FLOAT64"), + tiledb_dim("d2", c(0.5, 100.0), type = "FLOAT64") +)) tiledb_ndim(dom) } diff --git a/man/tiledb_ndrectangle.Rd b/man/tiledb_ndrectangle.Rd index d2e2bfd5d5..51f21e691e 100644 --- a/man/tiledb_ndrectangle.Rd +++ b/man/tiledb_ndrectangle.Rd @@ -18,10 +18,12 @@ The \code{tiledb_ndrectangle} object Creates a \code{tiledb_ndrectangle} object } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} if (tiledb_version(TRUE) >= "2.25.0") { - dom <-tiledb_domain(dim = tiledb_dim("d1", c(1L, 100L), type = "INT32")) - ndr <- tiledb_ndrectangle(dom) + dom <- tiledb_domain(dim = tiledb_dim("d1", c(1L, 100L), type = "INT32")) + ndr <- tiledb_ndrectangle(dom) } } diff --git a/man/tiledb_ndrectangle_datatype.Rd b/man/tiledb_ndrectangle_datatype.Rd index 3ab10ee233..265727b9ac 100644 --- a/man/tiledb_ndrectangle_datatype.Rd +++ b/man/tiledb_ndrectangle_datatype.Rd @@ -18,10 +18,12 @@ The \code{tiledb_ndrectangle} dimension datatype as a character Get the datatype of a named \code{tiledb_ndrectangle} dimension } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} if (tiledb_version(TRUE) >= "2.26.0") { - dom <- tiledb_domain(dim = tiledb_dim("d1", c(1L, 100L), type = "INT32")) - ndr <- tiledb_ndrectangle(dom) - tiledb_ndrectangle_datatype(ndr, "d1") + dom <- tiledb_domain(dim = tiledb_dim("d1", c(1L, 100L), type = "INT32")) + ndr <- tiledb_ndrectangle(dom) + tiledb_ndrectangle_datatype(ndr, "d1") } } diff --git a/man/tiledb_ndrectangle_datatype_by_ind.Rd b/man/tiledb_ndrectangle_datatype_by_ind.Rd index 9dc0156bd6..e32603be25 100644 --- a/man/tiledb_ndrectangle_datatype_by_ind.Rd +++ b/man/tiledb_ndrectangle_datatype_by_ind.Rd @@ -18,10 +18,12 @@ The \code{tiledb_ndrectangle} dimension datatype as a character Get the datatype of a \code{tiledb_ndrectangle} dimension by index } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} if (tiledb_version(TRUE) >= "2.26.0") { - dom <- tiledb_domain(dim = tiledb_dim("d1", c(1L, 100L), type = "INT32")) - ndr <- tiledb_ndrectangle(dom) - tiledb_ndrectangle_datatype_by_ind(ndr, 0) + dom <- tiledb_domain(dim = tiledb_dim("d1", c(1L, 100L), type = "INT32")) + ndr <- tiledb_ndrectangle(dom) + tiledb_ndrectangle_datatype_by_ind(ndr, 0) } } diff --git a/man/tiledb_ndrectangle_dim_num.Rd b/man/tiledb_ndrectangle_dim_num.Rd index 4963985af9..35b36a2c01 100644 --- a/man/tiledb_ndrectangle_dim_num.Rd +++ b/man/tiledb_ndrectangle_dim_num.Rd @@ -16,10 +16,12 @@ The number of dimentiones for the \code{tiledb_ndrectangle} Get the number of dimensions for \code{tiledb_ndrectangle} object } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} if (tiledb_version(TRUE) >= "2.26.0") { - dom <- tiledb_domain(dim = tiledb_dim("d1", c(1L, 100L), type = "INT32")) - ndr <- tiledb_ndrectangle(dom) - tiledb_ndrectangle_dim_num(ndr) + dom <- tiledb_domain(dim = tiledb_dim("d1", c(1L, 100L), type = "INT32")) + ndr <- tiledb_ndrectangle(dom) + tiledb_ndrectangle_dim_num(ndr) } } diff --git a/man/tiledb_ndrectangle_get_range.Rd b/man/tiledb_ndrectangle_get_range.Rd index 71e0510015..e07389095b 100644 --- a/man/tiledb_ndrectangle_get_range.Rd +++ b/man/tiledb_ndrectangle_get_range.Rd @@ -18,11 +18,13 @@ The \code{tiledb_ndrectangle} range as a two-element vector Get a range from a \code{tiledb_ndrectangle} object } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} if (tiledb_version(TRUE) >= "2.26.0") { - dom <- tiledb_domain(dim = tiledb_dim("d1", c(1L, 100L), type = "INT32")) - ndr <- tiledb_ndrectangle(dom) - ndr <- tiledb_ndrectangle_set_range(ndr, "d1", 50, 500) - tiledb_ndrectangle_get_range(ndr, "d1") + dom <- tiledb_domain(dim = tiledb_dim("d1", c(1L, 100L), type = "INT32")) + ndr <- tiledb_ndrectangle(dom) + ndr <- tiledb_ndrectangle_set_range(ndr, "d1", 50, 500) + tiledb_ndrectangle_get_range(ndr, "d1") } } diff --git a/man/tiledb_ndrectangle_set_range.Rd b/man/tiledb_ndrectangle_set_range.Rd index 613b9c4efd..e7bd38f533 100644 --- a/man/tiledb_ndrectangle_set_range.Rd +++ b/man/tiledb_ndrectangle_set_range.Rd @@ -26,10 +26,12 @@ string dimensions. Set a range on a \code{tiledb_ndrectangle} object } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} if (tiledb_version(TRUE) >= "2.26.0") { - dom <-tiledb_domain(dim = tiledb_dim("d1", c(1L, 100L), type = "INT32")) - ndr <- tiledb_ndrectangle(dom) - ndr <- tiledb_ndrectangle_set_range(ndr, "d1", 50, 500) + dom <- tiledb_domain(dim = tiledb_dim("d1", c(1L, 100L), type = "INT32")) + ndr <- tiledb_ndrectangle(dom) + ndr <- tiledb_ndrectangle_set_range(ndr, "d1", 50, 500) } } diff --git a/man/tiledb_query.Rd b/man/tiledb_query.Rd index d44ddc16e3..6f132a1900 100644 --- a/man/tiledb_query.Rd +++ b/man/tiledb_query.Rd @@ -6,8 +6,12 @@ \usage{ tiledb_query( array, - type = if (tiledb_version(TRUE) >= "2.12.0") c("READ", "WRITE", "DELETE", - "MODIFY_EXCLUSIVE") else c("READ", "WRITE"), + type = if (tiledb_version(TRUE) >= "2.12.0") { + c("READ", "WRITE", "DELETE", + "MODIFY_EXCLUSIVE") + } else { + c("READ", "WRITE") + }, ctx = tiledb_get_context() ) } diff --git a/man/tiledb_stats_dump.Rd b/man/tiledb_stats_dump.Rd index 1e0fd562a5..c2a986c8ac 100644 --- a/man/tiledb_stats_dump.Rd +++ b/man/tiledb_stats_dump.Rd @@ -14,7 +14,9 @@ if the empty string is passed then the result is displayed on stdout.} Dumps internal TileDB statistics to file or stdout } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} pth <- tempfile() tiledb_stats_dump(pth) cat(readLines(pth)[1:10], sep = "\n") diff --git a/man/tiledb_stats_raw_dump.Rd b/man/tiledb_stats_raw_dump.Rd index 87fb7b1d1d..ef279fbaab 100644 --- a/man/tiledb_stats_raw_dump.Rd +++ b/man/tiledb_stats_raw_dump.Rd @@ -10,7 +10,9 @@ tiledb_stats_raw_dump() This function requires TileDB Embedded 2.0.3 or later. } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} txt <- tiledb_stats_raw_dump() cat(txt, "\n") } diff --git a/man/tiledb_version.Rd b/man/tiledb_version.Rd index ee12bf6f98..3fb0874140 100644 --- a/man/tiledb_version.Rd +++ b/man/tiledb_version.Rd @@ -18,7 +18,9 @@ a \code{package_version} object The version of the libtiledb library } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} tiledb_version() tiledb_version(compact = TRUE) } diff --git a/man/tiledb_vfs.Rd b/man/tiledb_vfs.Rd index 061c5b045b..29c36a9d18 100644 --- a/man/tiledb_vfs.Rd +++ b/man/tiledb_vfs.Rd @@ -18,7 +18,9 @@ The \code{tiledb_vfs} object Creates a \code{tiledb_vfs} object } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} # default configuration vfs <- tiledb_vfs() diff --git a/man/tiledb_vfs_close.Rd b/man/tiledb_vfs_close.Rd index 8b210b8165..879cd0738a 100644 --- a/man/tiledb_vfs_close.Rd +++ b/man/tiledb_vfs_close.Rd @@ -7,7 +7,8 @@ tiledb_vfs_close(fh, ctx = tiledb_get_context()) } \arguments{ -\item{fh}{A TileDB VFS Filehandle external pointer as returned from \code{tiledb_vfs_open}} +\item{fh}{A TileDB VFS Filehandle external pointer as returned from +\code{tiledb_vfs_open}} \item{ctx}{(optional) A TileDB Ctx object} } diff --git a/man/tiledb_vfs_is_bucket.Rd b/man/tiledb_vfs_is_bucket.Rd index ca672cde78..249e8aa1b6 100644 --- a/man/tiledb_vfs_is_bucket.Rd +++ b/man/tiledb_vfs_is_bucket.Rd @@ -18,7 +18,9 @@ A boolean value indicating if it is a valid bucket Check for VFS Bucket } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} \dontrun{ cfg <- tiledb_config() cfg["vfs.s3.region"] <- "us-west-1" diff --git a/man/tiledb_vfs_is_empty_bucket.Rd b/man/tiledb_vfs_is_empty_bucket.Rd index 0b89af0c8b..38582646c5 100644 --- a/man/tiledb_vfs_is_empty_bucket.Rd +++ b/man/tiledb_vfs_is_empty_bucket.Rd @@ -18,7 +18,9 @@ A boolean value indicating if it is an empty bucket Check for empty VFS Bucket } \examples{ -\dontshow{ctx <- tiledb_ctx(limitTileDBCores())} +\dontshow{ +ctx <- tiledb_ctx(limitTileDBCores()) +} \dontrun{ cfg <- tiledb_config() cfg["vfs.s3.region"] <- "us-west-1" diff --git a/man/tiledb_vfs_read.Rd b/man/tiledb_vfs_read.Rd index 074746c92c..5f0dcb2dad 100644 --- a/man/tiledb_vfs_read.Rd +++ b/man/tiledb_vfs_read.Rd @@ -7,10 +7,11 @@ tiledb_vfs_read(fh, offset, nbytes, ctx = tiledb_get_context()) } \arguments{ -\item{fh}{A TileDB VFS Filehandle external pointer as returned from \code{tiledb_vfs_open}} +\item{fh}{A TileDB VFS Filehandle external pointer as returned from +\code{tiledb_vfs_open}} -\item{offset}{A scalar value with the byte offset from the beginning of the file -with a of zero.} +\item{offset}{A scalar value with the byte offset from the beginning of the +file with a of zero.} \item{nbytes}{A scalar value with the number of bytes to be read.} @@ -20,8 +21,9 @@ with a of zero.} The binary file content is returned as an integer vector. } \description{ -This interface currently defaults to reading an integer vector. This is suitable for R objects -as a raw vector used for (de)serialization can be mapped easily to an integer vector. It is -also possible to \code{memcpy} to the contiguous memory of an integer vector should other -(non-R) data be transferred. +This interface currently defaults to reading an integer vector. This is +suitable for R objects as a raw vector used for (de)serialization can be +mapped easily to an integer vector. It is also possible to \code{memcpy} to +the contiguous memory of an integer vector should other (non-R) data +be transferred. } diff --git a/man/tiledb_vfs_sync.Rd b/man/tiledb_vfs_sync.Rd index e6aa6e9a29..ff26bbe2dc 100644 --- a/man/tiledb_vfs_sync.Rd +++ b/man/tiledb_vfs_sync.Rd @@ -7,7 +7,8 @@ tiledb_vfs_sync(fh, ctx = tiledb_get_context()) } \arguments{ -\item{fh}{A TileDB VFS Filehandle external pointer as returned from \code{tiledb_vfs_open}} +\item{fh}{A TileDB VFS Filehandle external pointer as returned from +\code{tiledb_vfs_open}} \item{ctx}{(optional) A TileDB Ctx object} } diff --git a/man/tiledb_vfs_write.Rd b/man/tiledb_vfs_write.Rd index c83533ac38..f46df5bfc9 100644 --- a/man/tiledb_vfs_write.Rd +++ b/man/tiledb_vfs_write.Rd @@ -7,7 +7,8 @@ tiledb_vfs_write(fh, vec, ctx = tiledb_get_context()) } \arguments{ -\item{fh}{A TileDB VFS Filehandle external pointer as returned from \code{tiledb_vfs_open}} +\item{fh}{A TileDB VFS Filehandle external pointer as returned from +\code{tiledb_vfs_open}} \item{vec}{An integer vector of content to be written} @@ -17,8 +18,8 @@ tiledb_vfs_write(fh, vec, ctx = tiledb_get_context()) The result of the write operation is returned. } \description{ -This interface currently defaults to using an integer vector. This is suitable for R objects -as the raw vector result from serialization can be mapped easily to an integer vector. It is -also possible to \code{memcpy} to the contiguous memory of an integer vector should other -(non-R) data be transferred. +This interface currently defaults to using an integer vector. This is suitable +for R objects as the raw vector result from serialization can be mapped easily +to an integer vector. It is also possible to \code{memcpy} to the contiguous +memory of an integer vector should other (non-R) data be transferred. } diff --git a/tests/tinytest.R b/tests/tinytest.R index cec824041f..49bc7f5ffb 100644 --- a/tests/tinytest.R +++ b/tests/tinytest.R @@ -1,5 +1,5 @@ - -if (requireNamespace("tinytest", quietly=TRUE)) { - if (R.Version()$minor >= "2.0" && Sys.getenv("MY_UNIVERSE", "") == "") - tinytest::test_package("tiledb") +if (requireNamespace("tinytest", quietly = TRUE)) { + if (R.Version()$minor >= "2.0" && Sys.getenv("MY_UNIVERSE", "") == "") { + tinytest::test_package("tiledb") + } }