R/datasrc.R

In shunsambongi/dsi: Interfaces for data sources and datasets

# generics ----------------------------------------------------------------

#' [datasrc] Information
#'
#' Extract information about a [datasrc] object
#'
#' @param x a datasrc
#' @name datasrc-info
NULL

#' @rdname datasrc-info
#' @export
datasrc_name <- function(x) {
  UseMethod("datasrc_name")
}

#' @rdname datasrc-info
#' @export
datasrc_drv <- function(x) {
  UseMethod("datasrc_drv")
}

#' @rdname datasrc-info
#' @export
datasrc_args <- function(x) {
  UseMethod("datasrc_args")
}

#' [datasrc] Printing
#'
#' @param x a [datasrc] object
#' @param ... other params passed onto methods
#' @name datasrc-print
NULL

#' @rdname datasrc-print
#' @export
print_datasrc_header <- function(x, ...) {
  UseMethod("print_datasrc_header")
}

#' @rdname datasrc-print
#' @export
print_datasrc_body <- function(x, ...) {
  UseMethod("print_datasrc_body")
}

#' @rdname datasrc-print
#' @export
print_datasrc_footer <- function(x, ...) {
  UseMethod("print_datasrc_footer")
}


# S3 ----------------------------------------------------------------------

#' A `datasrc`
#'
#' At a hight level, a `datasrc` represents a group of data sets. So you can query
#' what datasets it has using [list_datasets()] and read and write datasets using
#' [read_dataset()] and [write_dataset()]. At a lower level, a `datasrc` is
#' more like a dynamic connection to such data source. This allows it to query
#' the data source for the requested data. At the lowest level, a `datasrc`
#' is a list of arguments (driver and named parameters) required to connect to a
#' data source. This allows it to automatically create a temporary connection
#' when needed to query the database.
#'
#' @param .name `datasrc` name
#' @param .drv `datasrc` driver
#' @param ... named arguments for connecting to `datasrc`
#' @param .subclass character vector of subclasses
#'
#' @export
datasrc <- function(.name, .drv, ..., .subclass = NULL) {
  args <- rlang::dots_list(..., .homonyms = "last")
  new_datasrc(args, .name, .drv, .subclass)
}

new_datasrc <- function(args, name, drv, subclass = NULL) {
  structure(args, name = name, drv = drv, class = c(subclass, "dsi_datasrc"))
}

#' @export
datasrc_name.dsi_datasrc <- function(x) {
  attr(x, "name")
}

#' @export
datasrc_drv.dsi_datasrc <- function(x) {
  drv <- attr(x, "drv")
  if (is_driver(drv)) return(drv)

  if (is.function(drv)) drv <- drv()
  stopifnot(is_driver(drv))
  drv
}

#' @export
datasrc_args.dsi_datasrc <- function(x) {
  nms <- names(x)
  attributes(x) <- NULL
  names(x) <- nms
  x
}


# print -------------------------------------------------------------------

#' @export
print.dsi_datasrc <- function(x, ...) {
  print_datasrc_header(x)
  print_datasrc_body(x)
  print_datasrc_footer(x)
  invisible(x)
}

#' @export
print_datasrc_header.dsi_datasrc <- function(x, ...) {
  cat(paste0("<datasrc: ", format(x), ">\n"))
  invisible(x)
}

#' @export
print_datasrc_body.dsi_datasrc <- function(x, ...) {
  args <- datasrc_args(x)
  nms <- rlang::names2(args)
  args <- vapply(seq_along(args), function(i) {
    name <- nms[i]
    out <- args[[i]]
    if (name != "") {
       out <- paste0(name, ": ", format(out))
    }
    out
  }, character(1))
  if (length(args)) {
    cat(paste0("  ", args), sep = "\n")
  }
  invisible(x)
}

#' @export
print_datasrc_footer.dsi_datasrc <- function(x, ...) {
  invisible(x)
}

#' @export
format.dsi_datasrc <- function(x, ...) {
  datasrc_name(x)
}


# cast --------------------------------------------------------------------

#' @export
as.list.dsi_datasrc <- function(x, ...) {
  datasrc_args(x)
}

# methods -----------------------------------------------------------------

#' @export
connect.dsi_datasrc <- function(x, ...) {
  args <- rlang::dots_list(!!!datasrc_args(x), ..., .homonyms = "last")
  rlang::exec(connect, datasrc_drv(x), !!!args)
}

#' @export
list_datasets.dsi_datasrc <- function(x, ...) {
  con <- connect_local(x)
  list_datasets(con, ...)
}

#' @export
read_dataset.dsi_datasrc <- function(x, name, ...) {
  con <- connect_local(x)
  read_dataset(con, name, ...)
}

#' @export
write_dataset.dsi_datasrc <- function(x, name, data, ...) {
  con <- connect_local(x)
  write_dataset(con, name, data, ...)
}

#' @export
remove_dataset.dsi_datasrc <- function(x, name, ...) {
  con <- connect_local(x)
  remove_dataset(con, name, ...)
}

#' @export
exists_dataset.dsi_datasrc <- function(x, name, ...) {
  con <- connect_local(x)
  exists_dataset(con, name, ...)
}

#' @export
list_fields.dsi_datasrc <- function(x, name, ...) {
  con <- connect_local(x)
  list_fields(con, name, ...)
}