feat: connectors as S7 object (#136)

Author: akselthomsen

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: connector
 Title: Streamlining Data Access in Clinical Research
-Version: 1.0.0.9000
+Version: 1.0.0.9001
 Authors@R: c(
     person("Cervan", "Girard", , "cgid@novonordisk.com", role = c("aut", "cre")),
     person("Aksel", "Thomsen", , "oath@novonordisk.com", role = "aut"),
@@ -28,12 +28,12 @@ Imports:
     glue,
     haven,
     jsonlite,
-    lifecycle,
     purrr,
     R6 (>= 2.4.0),
     readr,
     readxl,
     rlang,
+    S7,
     utils,
     vroom,
     writexl,

NAMESPACE

@@ -25,9 +25,6 @@ S3method(log_write_connector,ConnectorDBI)
 S3method(log_write_connector,ConnectorFS)
 S3method(log_write_connector,default)
 S3method(print,ConnectorLogger)
-S3method(print,cnts_datasources)
-S3method(print,connectors)
-S3method(print,nested_connectors)
 S3method(read_cnt,ConnectorDBI)
 S3method(read_cnt,ConnectorFS)
 S3method(read_cnt,ConnectorLogger)
@@ -86,7 +83,6 @@ export(connector_dbi)
 export(connector_fs)
 export(connectors)
 export(create_directory_cnt)
-export(datasources)
 export(disconnect_cnt)
 export(download_cnt)
 export(download_directory_cnt)

NEWS.md

@@ -1,3 +1,11 @@
+# connector dev
+
+## Breaking Changes
+* Previously deprecated `datasources()` function removed.
+
+## Enhancements
+* Changed `connectors()` and `nested_connectors()` to be S7 classes for more robust creation and use.
+
 # connector 1.0.0
 
 ## Breaking Changes

R/connect.R

@@ -104,7 +104,7 @@ connect <- function(
   if (is.null(names(config))) {
     names(config) <- purrr::map(config, "name")
     cnts <- config |>
-      purrr::map(\(x) connect(x, metadata, datasource, set_env))
+      purrr::map(\(x) connect(x, metadata, datasource, set_env, logging))
 
     return(do.call(nested_connectors, cnts))
   }
@@ -147,7 +147,7 @@ connect_from_config <- function(config) {
     config$datasources[[i]]$name <- config$datasources[[i]]$name[[1]]
   }
 
-  connections$datasources <- as_datasources(config["datasources"])
+  connections$.datasources <- datasources(config[["datasources"]])
 
   # Add metadata to the connections object
   if (!is.null(config$metadata)) {
@@ -157,15 +157,15 @@ connect_from_config <- function(config) {
       USE.NAMES = FALSE
     )
 
-    test <- any(names_co %in% ".md")
+    test <- any(names_co %in% c(".metadata", ".datasources"))
 
     if (test) {
       cli::cli_abort(
-        "'.md' is a reserved name. It cannot be used as a name for a data source."
+        "'.metadata' and '.datasources' are reserved names. They cannot be used as a name for a data source."
       )
     }
     # placeholder to be transformed as attribute in connectors
-    connections$.md <- config[["metadata"]]
+    connections$.metadata <- config[["metadata"]]
   }
 
   do.call(what = connectors, args = connections)

R/connectors.R

@@ -4,7 +4,10 @@
 #' Holds a special list of individual connector objects for consistent use of
 #' connections in your project.
 #'
-#' @param ... Named individual [Connector] objects
+#' @param ... Named individual [Connector] objects.
+#' @param .metadata `list()` of named metadata to store in the `@metadata` property.
+#' @param .datasources `list()` of datasource specifications to store in the `@datasources` property.
+#' If `NULL` (default) will be derived based on `...` input.
 #'
 #' @examples
 #' # Create connectors objects
@@ -18,47 +21,146 @@
 #'
 #' cnts
 #'
-#' # Print the individual connector for more information
+#' # Print the individual Connector for more information
 #'
 #' cnts$sdtm
 #'
 #' cnts$adam
 #'
-#' @export
-connectors <- function(...) {
-  x <- rlang::list2(...)
-  ds_ <- x[["datasources"]]
+#' @name connectors
+NULL
+
+#' @noRd
+construct_connectors <- function(
+  ...,
+  .metadata = list(),
+  .datasources = NULL
+) {
+  if (is.null(.datasources)) {
+    cnts <- substitute(rlang::list2(...))
+    .datasources <- connectors_to_datasources(cnts)
+  }
+
+  S7::new_object(
+    .parent = list(...),
+    metadata = .metadata,
+    datasources = datasources(.datasources)
+  )
+}
 
-  md_ <- if (is.null(x[[".md"]])) list() else x[[".md"]]
+#' @noRd
+validate_named <- function(x) {
+  if (!rlang::is_named2(x)) {
+    return("All elements must be named")
+  }
+}
+
+#' @noRd
+validate_datasources <- function(x) {
+  if (any(rlang::have_name(x))) {
+    return("All elements must be not be named")
+  }
 
-  if (!is.null(ds_) && !inherits(ds_, "cnts_datasources")) {
-    cli::cli_abort(
-      "'datasources' is a reserved name. It cannot be used as a name for a data source."
+  if (
+    any(
+      vapply(
+        X = x,
+        FUN = \(x) !setequal(c("name", "backend"), names(x)),
+        FUN.VALUE = logical(1)
+      )
     )
+  ) {
+    return("Each datasource must have (only) 'name' and 'backend' specified")
   }
 
-  if (is.null(ds_)) {
-    cnts <- substitute(rlang::list2(...))
-    datasources <- connectors_to_datasources(cnts)
-  } else {
-    datasources <- ds_
+  if (
+    any(
+      vapply(
+        X = x,
+        FUN = \(x) !"type" %in% names(x[["backend"]]),
+        FUN.VALUE = logical(1)
+      )
+    )
+  ) {
+    return("Each datasource must have backend type specified")
   }
+}
 
-  checkmate::assert_list(x = x, names = "named")
 
-  structure(
-    x[!(names(x) %in% c("datasources", ".md"))],
-    class = c("connectors"),
-    datasources = datasources,
-    metadata = md_
-  )
+#' @noRd
+validate_connectors <- function(x) {
+  if (!length(x)) {
+    return("At least one Connector must be supplied")
+  }
+
+  if (
+    !all(
+      vapply(
+        X = x,
+        FUN = \(x) is_connector(x),
+        FUN.VALUE = logical(1)
+      )
+    )
+  ) {
+    return("All elements must be a Connector object")
+  }
+
+  if (length(x) != length(x@datasources)) {
+    return("Each 'Connector' must have a corresponding datasource")
+  }
+
+  validate_named(x)
 }
 
+#' @noRd
+prop_metadata <- S7::new_property(
+  class = S7::class_list,
+  getter = \(self) self@metadata,
+  validator = \(value) validate_named(value)
+)
+
+#' @noRd
+datasources <- S7::new_class(
+  name = "datasources",
+  parent = S7::class_list,
+  validator = \(self) validate_datasources(self)
+)
+
+#' @noRd
+prop_datasources <- S7::new_property(
+  class = datasources,
+  getter = \(self) self@datasources
+)
+
+#' @rdname connectors
 #' @export
-print.connectors <- function(x, ...) {
+connectors <- S7::new_class(
+  name = "connectors",
+  parent = S7::class_list,
+  properties = list(
+    metadata = prop_metadata,
+    datasources = prop_datasources
+  ),
+  constructor = construct_connectors,
+  validator = \(self) validate_connectors(self)
+)
+
+#' @noRd
+S7::method(print, connectors) <- function(x, ...) {
   print_connectors(x, ...)
 }
 
+#' @noRd
+S7::method(print, datasources) <- function(x, ...) {
+  print_datasources(x, ...)
+}
+
+#' @noRd
+is_connectors <- function(x) {
+  S7::S7_inherits(x, connectors) |
+    S7::S7_inherits(x, nested_connectors)
+}
+
 #' @noRd
 print_connectors <- function(x, ...) {
   classes <- x |>
@@ -95,11 +197,11 @@ print_connectors <- function(x, ...) {
   return(invisible(x))
 }
 
-#' @export
-print.cnts_datasources <- function(x, ...) {
+#' @noRd
+print_datasources <- function(x, ...) {
   cli::cli_h1("Datasources")
 
-  for (ds in x[["datasources"]]) {
+  for (ds in x) {
     cli::cli_h2(ds$name)
     cli::cli_ul()
     cli::cli_li("Backend Type: {.val {ds$backend$type}}")
@@ -110,39 +212,5 @@ print.cnts_datasources <- function(x, ...) {
     cli::cli_end()
   }
 
-  return(x)
-}
-
-#' @noRd
-as_datasources <- function(...) {
-  structure(
-    ...,
-    class = "cnts_datasources"
-  )
-}
-
-#' Create a nested connectors object
-#'
-#' This function creates a nested connectors object from the provided arguments.
-#'
-#' @param ... Any number of connectors object.
-#'
-#' @return A list with class "nested_connectors" containing the provided arguments.
-#' @export
-nested_connectors <- function(...) {
-  x <- rlang::list2(...)
-  structure(
-    x,
-    class = c("nested_connectors")
-  )
-}
-
-#' @export
-print.nested_connectors <- function(x, ...) {
-  print_connectors(x, ...)
-}
-
-#' @noRd
-is_connectors <- function(connectors) {
-  inherits(connectors, "connectors")
+  return(invisible(x))
 }