R/Array.R

In TileDB-Inc/TileDB-R: Modern Database Engine for Complex Data Based on Multi-Dimensional Arrays

#  MIT License
#
#  Copyright (c) 2017-2024 TileDB Inc.
#
#  Permission is hereby granted, free of charge, to any person obtaining a copy
#  of this software and associated documentation files (the "Software"), to deal
#  in the Software without restriction, including without limitation the rights
#  to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
#  copies of the Software, and to permit persons to whom the Software is
#  furnished to do so, subject to the following conditions:
#
#  The above copyright notice and this permission notice shall be included in all
#  copies or substantial portions of the Software.
#
#  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
#  IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
#  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
#  AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
#  LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
#  OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
#  SOFTWARE.

#' Creates a new TileDB array given an input schema.
#'
#' @param uri URI specifying path to create the TileDB array object
#' @param schema tiledb_array_schema object
#' @param encryption_key optional A character value with an AES-256 encryption key
#' in case the array should be encrypted.
#'
#' @examples
#' \dontshow{
#' ctx <- tiledb_ctx(limitTileDBCores())
#' }
#' \dontrun{
#' pth <- tempdir()
#' 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_array_create(pth, sch)
#' tiledb_object_type(pth)
#' }
#'
#' @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))
  }
}

##' Open a TileDB Array
##'
##' @param arr A TileDB Array object as for example returned by `tiledb_array()`
##' @param type A character value that must be either \sQuote{READ}, \sQuote{WRITE}
##' or (for TileDB 2.12.0 or later) \sQuote{DELETE} or \sQuote{MODIFY_EXCLUSIVE}
##' @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")
  }
) {
  stopifnot("The 'arr' argument must be a tiledb_array object" = .isArray(arr))
  type <- match.arg(type)

  if (.hasSlot(arr, "encryption_key") && length(arr@encryption_key) > 0) {
    ctx <- tiledb_get_context()
    arr@ptr <- libtiledb_array_open_with_key(ctx@ptr, arr@uri, type, arr@encryption_key)
  } else {
    arr@ptr <- libtiledb_array_open_with_ptr(arr@ptr, type)
  }
  arr
}

##' Open a TileDB Array at Timestamp
##'
##' @param arr A TileDB Array object as for example returned by \code{tiledb_array()}
##' @param type A character value that must be either \sQuote{READ} or \sQuote{WRITE}
##' @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")
  )
  type <- match.arg(type)
  ctx <- tiledb_get_context()
  if (.hasSlot(arr, "encryption_key") && length(arr@encryption_key) > 0) {
    arr@ptr <- libtiledb_array_open_at_with_key(ctx@ptr, arr@uri, type, arr@encryption_key, timestamp)
  } else {
    arr@ptr <- libtiledb_array_open_at(ctx@ptr, arr@uri, type, timestamp)
  }
  arr
}


##' Close a TileDB Array
##'
##' @param arr A TileDB Array object as for example returned by `tiledb_array()`
##' @return The TileDB Array object but closed
##' @export
tiledb_array_close <- function(arr) {
  stopifnot("The 'arr' argument must be a tiledb_array object" = .isArray(arr))
  libtiledb_array_close(arr@ptr)
  arr
}

##' Test if TileDB Array is open
##'
##' @param arr A TileDB Array object as for example returned by `tiledb_array()`
##' @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)
}

##' Test if TileDB Array is open for reading
##'
##' @param arr A TileDB Array object as for example returned by `tiledb_array()`
##' @return A boolean indicating whether the TileDB Array object is open, and
##' the mode is "READ".
##' @export
tiledb_array_is_open_for_reading <- function(arr) {
  stopifnot("The 'arr' argument must be a tiledb_array object" = .isArray(arr))
  return(libtiledb_array_is_open_for_reading(arr@ptr))
}

##' Test if TileDB Array is open for writing
##'
##' @param arr A TileDB Array object as for example returned by `tiledb_array()`
##' @return A boolean indicating whether the TileDB Array object is open, and
##' the mode is "WRITE".
##' @export
tiledb_array_is_open_for_writing <- function(arr) {
  stopifnot("The 'arr' argument must be a tiledb_array object" = .isArray(arr))
  return(libtiledb_array_is_open_for_writing(arr@ptr))
}

##' Check for Homogeneous Domain
##'
##' @param arr A TileDB Array object
##' @return A boolean indicating if the array has homogeneous domains
##' @export
tiledb_array_is_homogeneous <- function(arr) {
  stopifnot("The 'arr' argument must be a tiledb_array object" = .isArray(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
  )
  n <- length(unique(domaintype))
  n == 1
}

##' Check for Heterogeneous Domain
##'
##' @param arr A TileDB Array object
##' @return A boolean indicating if the array has heterogenous domains
##' @export
tiledb_array_is_heterogeneous <- function(arr) {
  stopifnot("The 'arr' argument must be a tiledb_array object" = .isArray(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
  )
  n <- length(unique(domaintype))
  n > 1
}

##' Delete fragments written between the start and end times given
##'
##' @param arr A TileDB Array object as for example returned by \code{tiledb_array()}
##' @param ts_start A Datetime object that will be converted to millisecond granularity
##' @param ts_end A Datetime object that will be converted to millisecond granularity
##' @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)
}

##' Delete fragments written given by their URIs
##'
##' @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)
}

##' Check for Enumeration (aka Factor aka Dictionary)
##'
##' @param arr A TileDB Array object
##' @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))
}

##' Run an aggregate query on the given (sparse) array and attribute
##'
##' For dense arrays, use \code{tiledb_query_apply_aggregate} after setting an
##' appropriate subarray.
##'
##' @param array A TileDB Array object
##' @param attrname The name of an attribute
##' @param operation The name of aggregation operation
##' @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)
  )

  operation <- match.arg(operation)

  if (tiledb_array_is_open(array)) {
    array <- tiledb_array_close(array)
  }

  query <- tiledb_query(array, "READ")

  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)
}

##' Upgrade an Array to the current TileDB Array Schema Format
##'
##' @param array A TileDB Array object
##' @param config A TileDB Configuration (optional, default NULL)
##' @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
  )
}