database source options

NAMESPACE

@@ -5,6 +5,7 @@ export(commons_server)
 export(commons_ui)
 export(context_layer)
 export(data_source)
+export(data_source_options)
 export(list_tables)
 export(measure)
 export(semantic_layer)

R/data-source-options.R

@@ -0,0 +1,128 @@
+#' Configure a database data source
+#'
+#' `data_source_options()` controls which objects a DBI-backed [data_source()]
+#' exposes. Character values select literal table names. Use [DBI::Id()] to
+#' preserve catalog and schema components or to select a name containing dots.
+#'
+#' @param include Exact tables to expose: a character vector, a [DBI::Id()], or
+#'   a list of `DBI::Id()` objects. An ID without a `table` component represents
+#'   a namespace; namespace expansion requires backend catalog support and is
+#'   not yet available.
+#' @return A `commons_data_source_options` object for [data_source()].
+#' @export
+data_source_options <- function(include = NULL) {
+  structure(
+    list(include = normalize_connection_includes(include)),
+    class = "commons_data_source_options"
+  )
+}
+
+check_data_source_options <- function(
+  options,
+  tables,
+  kind,
+  call = rlang::caller_env()
+) {
+  if (is.null(options)) {
+    return(NULL)
+  }
+  if (!identical(kind, "connection")) {
+    cli::cli_abort(
+      "{.arg options} can only be used with a DBI connection.",
+      call = call
+    )
+  }
+  if (!is.null(tables)) {
+    cli::cli_abort(
+      "Supply only one of {.arg tables} and {.arg options}.",
+      call = call
+    )
+  }
+  if (!inherits(options, "commons_data_source_options")) {
+    cli::cli_abort(
+      "{.arg options} must come from {.fn data_source_options}.",
+      call = call
+    )
+  }
+  options
+}
+
+normalize_connection_includes <- function(
+  include,
+  call = rlang::caller_env()
+) {
+  if (is.null(include)) {
+    return(NULL)
+  }
+
+  entries <- if (inherits(include, "Id")) {
+    list(include)
+  } else if (is.character(include)) {
+    if (anyNA(include) || any(!nzchar(include))) {
+      cli::cli_abort(
+        "Character entries in {.arg include} must be non-empty table names.",
+        call = call
+      )
+    }
+    lapply(include, function(table) DBI::Id(table = table))
+  } else if (is.list(include)) {
+    include
+  } else {
+    cli::cli_abort(
+      paste0(
+        "{.arg include} must be a character vector, a {.cls DBI::Id}, ",
+        "or a list of {.cls DBI::Id} objects."
+      ),
+      call = call
+    )
+  }
+
+  if (length(entries) == 0) {
+    cli::cli_abort(
+      "{.arg include} must select at least one object.",
+      call = call
+    )
+  }
+  if (!all(vapply(entries, inherits, logical(1), "Id"))) {
+    cli::cli_abort(
+      "Every entry in {.arg include} must be a {.cls DBI::Id}.",
+      call = call
+    )
+  }
+
+  for (id in entries) {
+    components <- id@name
+    if (any(is.na(components) | components == "")) {
+      cli::cli_abort(
+        "{.cls DBI::Id} entries in {.arg include} must have non-empty components.",
+        call = call
+      )
+    }
+  }
+
+  entries
+}
+
+check_exact_connection_includes <- function(
+  include,
+  call = rlang::caller_env()
+) {
+  prefixes <- vapply(
+    include,
+    function(id) is.na(id@name["table"]),
+    logical(1)
+  )
+  if (any(prefixes)) {
+    cli::cli_abort(
+      c(
+        "Namespace selections in {.arg options} are not yet supported.",
+        i = paste0(
+          "Select exact tables by adding a {.arg table} component to each ",
+          "{.fn DBI::Id}; backend namespace expansion will be added separately."
+        )
+      ),
+      call = call
+    )
+  }
+  invisible(include)
+}

R/data-source.R

@@ -39,6 +39,9 @@
 #'
 #'   For a board, a named character vector of pins to read: the names become
 #'   table names, and the values are pin names passed to [pins::pin_read()].
+#' @param options Database selection controls from [data_source_options()].
+#'   This argument is supported only when `...` is a
+#'   DBI connection. Supply only one of `tables` and `options`.
 #' @param dictionary An optional path to a data dictionary describing the
 #'   source's tables and columns, in the
 #'   [data-dict.yaml](https://data-dict.tidyverse.org/) format. See the
@@ -85,18 +88,24 @@
 #' list_tables(src)
 #'
 #' @export
-data_source <- function(..., tables = NULL, dictionary = NULL) {
+data_source <- function(..., tables = NULL, dictionary = NULL, options = NULL) {
   dots <- rlang::list2(...)
   dictionary <- as_data_dictionary(dictionary)
   kind <- data_source_kind(dots)
+  options <- check_data_source_options(options, tables, kind)
 
   local_commons_span(
     "commons_data_source_create",
     attributes = list("commons.data_source.kind" = kind)
   )
 
   if (kind == "connection") {
-    return(data_source_connection(dots[[1]], tables, dictionary = dictionary))
+    return(data_source_connection(
+      dots[[1]],
+      tables,
+      dictionary = dictionary,
+      options = options
+    ))
   }
   if (kind == "board") {
     return(data_source_board(dots[[1]], tables, dictionary = dictionary))
@@ -139,18 +148,39 @@ data_source_connection <- function(
   con,
   tables,
   dictionary = NULL,
+  options = NULL,
   call = rlang::caller_env()
 ) {
   span <- local_commons_span("commons_data_source_list_tables")
 
-  if (is.null(tables)) {
+  include <- options$include %||% tables
+  if (is.null(include)) {
     listed <- DBI::dbListTables(con)
     commons_span_set_attribute(span, "commons.data_source.n_tables", length(listed))
-    return(new_data_source(con, listed, owned = FALSE, dictionary = dictionary))
+    return(new_data_source(
+      con,
+      listed,
+      owned = FALSE,
+      dictionary = dictionary,
+      options = options
+    ))
   }
 
-  table_registry <- normalize_table_registry(tables, call = call)
-  check_table_ids_exist(con, table_registry, call = call)
+  if (!is.null(options)) {
+    check_exact_connection_includes(include, call = call)
+  }
+  argument <- if (is.null(options)) "tables" else "include"
+  table_registry <- normalize_table_registry(
+    include,
+    call = call,
+    argument = argument
+  )
+  check_table_ids_exist(
+    con,
+    table_registry,
+    call = call,
+    argument = argument
+  )
   commons_span_set_attribute(
     span,
     "commons.data_source.n_tables",
@@ -162,7 +192,8 @@ data_source_connection <- function(
     table_registry$labels,
     owned = FALSE,
     table_ids = table_registry$ids,
-    dictionary = dictionary
+    dictionary = dictionary,
+    options = options
   )
 }
 
@@ -241,7 +272,8 @@ new_data_source <- function(
   owned,
   table_ids = table_ids_from_labels(tables),
   dictionary = NULL,
-  pending = NULL
+  pending = NULL,
+  options = NULL
 ) {
   # Disconnect only the DuckDB connection we created; a user-supplied connection
   # has its own owner and lifetime.
@@ -263,7 +295,8 @@ new_data_source <- function(
       table_ids = table_ids,
       handle = handle,
       dictionary = dictionary,
-      pending = pending
+      pending = pending,
+      options = options
     ),
     class = "commons_data_source"
   )
@@ -561,15 +594,19 @@ duckdb_connect <- function() {
   con
 }
 
-normalize_table_registry <- function(tables, call = rlang::caller_env()) {
+normalize_table_registry <- function(
+  tables,
+  call = rlang::caller_env(),
+  argument = "tables"
+) {
   entries <- table_entries(tables, call = call)
   ids <- lapply(entries, table_entry_id, call = call)
   labels <- vapply(ids, table_id_label, character(1), call = call)
 
   duplicated_labels <- unique(labels[duplicated(labels)])
   if (length(duplicated_labels)) {
     cli::cli_abort(
-      "{.arg tables} must not contain duplicate labels: {.val {duplicated_labels}}.",
+      "{.arg {argument}} must not contain duplicate labels: {.val {duplicated_labels}}.",
       call = call
     )
   }
@@ -661,7 +698,12 @@ table_ids_from_labels <- function(tables) {
 # startup against a remote warehouse. Probe every table in a single zero-row
 # query instead, and fall back to per-table checks only to name the missing
 # tables when that probe fails.
-check_table_ids_exist <- function(con, table_registry, call = rlang::caller_env()) {
+check_table_ids_exist <- function(
+  con,
+  table_registry,
+  call = rlang::caller_env(),
+  argument = "tables"
+) {
   probes <- vapply(
     table_registry$ids,
     function(id) {
@@ -689,14 +731,14 @@ check_table_ids_exist <- function(con, table_registry, call = rlang::caller_env(
 
   if (length(missing) == 0) {
     cli::cli_abort(
-      "Failed to verify {.arg tables} against the connection.",
+      "Failed to verify {.arg {argument}} against the connection.",
       parent = probe_error,
       call = call
     )
   }
 
   cli::cli_abort(
-    "{.arg tables} names table{?s} not on the connection: {.val {missing}}.",
+    "{.arg {argument}} names table{?s} not on the connection: {.val {missing}}.",
     call = call
   )
 }