diff --git a/R/ArraySchema.R b/R/ArraySchema.R index 4114fc3956..3d3fafc48f 100644 --- a/R/ArraySchema.R +++ b/R/ArraySchema.R @@ -1,6 +1,6 @@ # MIT License # -# Copyright (c) 2017-2024 TileDB Inc. +# Copyright (c) 2017-2025 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 @@ -60,7 +60,7 @@ tiledb_array_schema.from_ptr <- function(ptr, arrptr = NULL) { #' ctx <- tiledb_ctx(limitTileDBCores()) #' } #' schema <- tiledb_array_schema( -#' dom = tiledb_domain( +#' domain = tiledb_domain( #' dims = c( #' tiledb_dim("rows", c(1L, 4L), 4L, "INT32"), #' tiledb_dim("cols", c(1L, 4L), 4L, "INT32") @@ -95,7 +95,7 @@ tiledb_array_schema <- function( } # 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))) + "'attrs' must be a list of 'tiledb_attr' objects" = all(vapply(attrs, is_attr, logical(1))) ) } else { attrs <- NULL @@ -114,7 +114,22 @@ tiledb_array_schema <- function( ) # 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() + if (is.list(attrs)) { + attr_names <- sapply(attrs, name) + attr_ptr_list <- lapply(attrs, function(obj) slot(obj, "ptr")) + names(attr_ptr_list) <- attr_names + + # Do not allow enum named list to have different names than attributes + if (!is.null(enumerations)) { + if (!all(names(enumerations) %in% attr_names)) { + stop("'enumerations' should be a named list mapped to attributes names") + } + } + + } else { + attr_ptr_list <- 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 diff --git a/inst/tinytest/test_arrayschema.R b/inst/tinytest/test_arrayschema.R index 2fb9a5a7cd..6d43d8b2a0 100644 --- a/inst/tinytest/test_arrayschema.R +++ b/inst/tinytest/test_arrayschema.R @@ -153,3 +153,120 @@ if (tiledb_version(TRUE) < "2.27.0") { } else { expect_silent(tiledb_array_schema_set_current_domain(dsch, cd)) } + +## enumerations +if (tiledb_version(TRUE) >= "2.17.0") { + +dom <- tiledb_domain(c(tiledb_dim( + name = "id", + domain = c(NULL, NULL), + tile = NULL, + type = "ASCII"))) + +attrs <- c( + + tiledb_attr( + name = "col1", + type = "INT32", + ncells = 1, + nullable = FALSE), + tiledb_attr( + name = "enum1", + type = "INT32", + ncells = 1, + nullable = FALSE, + enumeration = TRUE + ), + tiledb_attr( + name = "col2", + type = "INT32", + ncells = 1, + nullable = FALSE + ), + tiledb_attr( + name = "enum2", + type = "INT32", + ncells = 1, + nullable = FALSE, + enumeration = TRUE + ), + tiledb_attr( + name = "enum3", + type = "INT32", + ncells = 1, + nullable = FALSE, + enumeration = TRUE + ) +) + +# case 1 (ordered enums) +uri <- tempfile() + +enums <- list( + enum1 = c("A", "B"), + enum2 = c("yes", "no"), + enum3 = c("aa") +) + +sch <- tiledb_array_schema(domain = dom, attrs = attrs, sparse = TRUE, enumerations = enums) +tiledb_array_create(uri, sch) +arr <- tiledb_array(uri) + +# columns with enums +trg <- c(col1 = FALSE, enum1 = TRUE, col2 = FALSE, enum2 = TRUE, enum3 = TRUE) + +expect_equal(tiledb_array_has_enumeration(arr), trg) + +unlink(uri) + +# case 2 (unordered enums) +uri <- tempfile() + +enums <- list( + enum2 = c("yes", "no"), + enum1 = c("A", "B"), + enum3 = c("aa") +) + +sch <- tiledb_array_schema(domain = dom, attrs = attrs, sparse = TRUE, enumerations = enums) +tiledb_array_create(uri, sch) +arr <- tiledb_array(uri) + +expect_equal(tiledb_array_has_enumeration(arr), trg) + +unlink(uri) + +# case 3 (unordered map all attributes) +uri <- tempfile() + +enums <- list( + enum1 = c("A", "B"), + col1 = NULL, + enum2 = c("yes", "no"), + enum3 = c("aa"), + col2 = NULL +) + + +sch <- tiledb_array_schema(domain = dom, attrs = attrs, sparse = TRUE, enumerations = enums) +tiledb_array_create(uri, sch) +arr <- tiledb_array(uri) + +expect_equal(tiledb_array_has_enumeration(arr), trg) + +# case 4 (unknown mapping name) +uri <- tempfile() + +enums <- list( + name = c("A", "B"), + col1 = NULL, + enum2 = c("yes", "no"), + enum3 = c("aa"), + col2 = NULL +) + +# enums contains a named element that is not found in attributes +expect_error(tiledb_array_schema(domain = dom, attrs = attrs, sparse = TRUE, enumerations = enums)) + +unlink(uri) +} diff --git a/man/tiledb_array_schema.Rd b/man/tiledb_array_schema.Rd index 8ee0248150..c20d8a75d1 100644 --- a/man/tiledb_array_schema.Rd +++ b/man/tiledb_array_schema.Rd @@ -55,7 +55,7 @@ Constructs a \code{tiledb_array_schema} object ctx <- tiledb_ctx(limitTileDBCores()) } schema <- tiledb_array_schema( - dom = tiledb_domain( + domain = tiledb_domain( dims = c( tiledb_dim("rows", c(1L, 4L), 4L, "INT32"), tiledb_dim("cols", c(1L, 4L), 4L, "INT32") diff --git a/src/libtiledb.cpp b/src/libtiledb.cpp index 01ea2080dc..9aaf3e96e5 100644 --- a/src/libtiledb.cpp +++ b/src/libtiledb.cpp @@ -1914,11 +1914,15 @@ XPtr libtiledb_array_schema( for (R_xlen_t i = 0; i < nenum; i++) { bool nn = enumerations[i] == R_NilValue; if (nn == false) { - XPtr attr = - as>(attributes[i]); std::vector enums = as>(enumerations[i]); std::string enum_name = std::string(enumnames[i]); + + // Get attribute by enum name ('attributes' list is named from R level) + // See https://github.com/TileDB-Inc/TileDB-R/issues/853 + XPtr attr = + as>(attributes[enum_name]); + bool is_ordered = false; // default // 'ordered' is an attribute off the CharacterVector CharacterVector enumvect = enumerations[i];