R/class_methods.R

In ohvbd: One Health VBD Hub

# nolint start: object_name_linter

# Printers

#' @export
print.ohvbd.ids <- function(x, ...) {
  cli::cat_line(cli::format_inline("{.cls {class(x)[1]}}"))
  cat(paste0("Database: ", ohvbd_db(x), "\n"))
  if (is.numeric(x)) {
    print(as.numeric(x))
  } else {
    print(as.character(x))
  }
  invisible(x)
}

#' @export
print.ohvbd.data.frame <- function(x, ...) {
  cli::cat_line(cli::format_inline("{.cls {class(x)[1]}}"))
  cat(paste0("Database: ", ohvbd_db(x), "\n"))
  print(as.data.frame(x))
  invisible(x)
}

#' @export
print.ohvbd.ad.matrix <- function(x, ..., full = TRUE) {
  cli::cat_line(cli::format_inline("{.cls {class(x)[1]}}"))
  # If attr is null, default to <missing>
  metric <- attr(x, 'metric') %||% '<missing>'
  gid <- attr(x, 'gid') %||% '<missing>'
  cached <- attr(x, 'cached') %||% 'unknown'
  startdate <- head(colnames(x), 1) %||% 'unknown'
  enddate <- tail(colnames(x), 1) %||% 'unknown'
  if (!is.null(options("cli.default_handler"))) {
    # If default handler is null, cli output is being suppressed
    cat(paste("Areadata matrix for", metric, "at gid level", gid, ".\n"))
    cat(paste("Cached:", cached, "\n"))
    cat(paste("Dates:", startdate, "->", enddate, paste0("(", ncol(x), ")\n")))
    cat(paste("Locations:", nrow(x), "\n"))
    if (full) {
      cat("Data:\n")
      NextMethod(object = matrix())
    }
  } else {
    cli::cli_text(
      "Areadata matrix for {.val {metric}} at gid level {.val {gid}}."
    )
    cli::cli_text("Cached: {.val {cached}}")
    cli::cli_text(
      "Dates: {.val {startdate}} -> {.val {enddate}} ({.val {ncol(x)}})"
    )
    cli::cli_text("Locations: {.val {nrow(x)}}")
    if (full) {
      cli::cli_h1("Data")
      NextMethod(object = matrix())
    }
  }
  invisible(x)
}

#' @export
summary.ohvbd.ad.matrix <- function(object, ...) {
  # Shortcut to just print AD header
  print.ohvbd.ad.matrix(object, ..., full = FALSE)
  invisible(object)
}

#' @export
print.ohvbd.hub.search <- function(x, ...) {
  cli::cat_line(cli::format_inline("{.cls {class(x)[1]}}"))
  cat(paste0("Rows: ", nrow(x), ", Query: ", attr(x, "query"), "\n"))
  print(as.data.frame(x))
  invisible(x)
}

#' @export
summary.ohvbd.hub.search <- function(object, ...) {
  # fmt: skip
  cat(paste0("Rows: ", nrow(object) , ", Query: ", attr(object, "query"), "\n\nSplit by database:"))
  print(table(object$db))
  invisible(object)
}

# Indexers

#' @export
`[.ohvbd.ids` <- function(x, i) {
  new_ohvbd.ids(NextMethod(), db = ohvbd_db(x))
}

#' @title Fetch specified data from a set of ids
#'
#' @description
#' This is a convenience method that infers and applies the correct fetch function for the input ids.
#' @author Francis Windram
#'
#' @param ids An object of type `ohvbd.ids` (generated from a search, manually packaged using [ohvbd.ids()] or generated by another function).
#' @param ... Any other arguments to be passed to the underlying fetch functions (see [fetch_vt()] and [fetch_vd()] for specific arguments).
#' @returns The downloaded data, as an `ohvbd.responses` object.
#' @concept convenience
#' @export
#' @examplesIf interactive()
#' search_hub("Ixodes", "vt") |> fetch()
#'
fetch <- function(
  ids,
  ...
) {
  UseMethod("fetch")
}

#' @export
fetch.ohvbd.ids <- function(
  ids,
  ...
) {
  db <- list(...)$db
  if (is.null(db)) {
    # If not overriding db, just use the one provided
    db <- ohvbd_db(ids) %||%
      cli::cli_abort(
        c(
          "x" = "No db attached to the dataset and none specified!",
          "i" = "Either specify using the {.arg db} argument, or use {.fn ohvbd::force_db}"
        )
      )
  }
  finalfun <- switch(
    db,
    "vt" = fetch_vt,
    "vd" = fetch_vd,
    "gbif" = fetch_gbif,
    cli::cli_abort(
      "No method to fetch data from db {.val {db}} for class{?es} {.cls {class(x)}}"
    )
  )
  return(finalfun(ids, ...))
}

#' @export
fetch.ohvbd.hub.search <- function(
  ids,
  ...
) {
  # Could consider in the future making this method parse the individual dbs
  # and run their respective fetchers, but this would add a lot of complexity
  # when it comes to gleaning.
  cli::cli_abort(c(
    "x" = "Cannot fetch an {.cls ohvbd.hub.search} object!",
    "!" = "Did you forget to use {.fn ohvbd::filter_db} after searching?"
  ))
}

#' @title Extract specified data from a set of responses
#'
#' @description
#' This is a convenience method that infers and applies the correct extractor for the input
#' @author Francis Windram
#'
#' @param res An object of type `ohvbd.responses` or `ohvbd.ad.matrix` generated from [fetch()]
#' and containing data from one of the supported databases.
#' @param ... Any arguments to be passed to the underlying extractors (unused).
#' @returns The extracted data, either as an `ohvbd.data.frame` or `ohvbd.ad.matrix` object.
#' @concept convenience
#' @export
#' @examplesIf interactive()
#' search_hub("Ixodes", "vt") |> fetch() |> glean(cols=c("Interactor1Species"))
#' fetch_ad(use_cache=TRUE) |> glean(targetdate="2020-08-04")
#'
glean <- function(res, ...) {
  UseMethod("glean")
}

#' @export
glean.ohvbd.responses <- function(
  res,
  ...,
  cols = NULL,
  returnunique = FALSE,
  db = NULL
) {
  if (is.null(db)) {
    # If not overriding database, just use the one provided
    db <- ohvbd_db(res) %||%
      cli::cli_abort(
        c(
          "x" = "No database attached to the dataset and none specified!",
          "i" = "Either specify using the {.arg db} argument, or use {.fn ohvbd::force_db}"
        )
      )
  }
  finalfun <- switch(
    db,
    "vt" = glean_vt,
    "vd" = glean_vd,
    "gbif" = glean_gbif,
    cli::cli_abort(
      "No method to extract data from db {.val {db}} for class{?es} {.cls {class(x)}}"
    )
  )
  return(finalfun(res, cols, returnunique))
}

#' @export
glean.ohvbd.ad.matrix <- function(
  res,
  ...,
  targetdate = NA,
  enddate = NA,
  places = NULL,
  gid = NULL
) {
  db <- ohvbd_db(res)
  return(glean_ad(res, targetdate, enddate, places, gid))
}

#' @export
glean.ohvbd.ids <- function(
  res,
  ...
) {
  # Could consider in the future making this method parse the individual dbs
  # and run their respective fetchers, but this would add a lot of complexity
  # when it comes to gleaning.
  cli::cli_abort(c(
    "x" = "Cannot glean an {.cls ohvbd.ids} object!",
    "!" = "Did you forget to use {.fn ohvbd::fetch} after searching?"
  ))
}

#' @title Try to find the relevant citations for a dataset
#'
#' @description
#' This tries to extract and simplify the citations from a dataset downloaded using `ohvbd`.
#' @author Francis Windram
#'
#' @param dataset An object of type `ohvbd.data.frame` (generated from [glean()], preferred) or of type `ohvbd.ids`
#' and containing data from one of the supported databases.
#' @param ... Any arguments to be passed to the underlying funcs.
#' @returns The extracted data, either as an `ohvbd.data.frame` or `ohvbd.ad.matrix` object.
#' @concept convenience
#' @export
#' @examplesIf interactive()
#' search_hub("Ixodes", "vt") |>
#'   fetch() |>
#'   glean() |>
#'   fetch_citations()
#'
fetch_citations <- function(dataset, ...) {
  UseMethod("fetch_citations")
}

#' @export
fetch_citations.ohvbd.ids <- function(
    dataset,
    ...
) {
  cli::cli_alert_info("Treating {.cls ohvbd.ids} object as a 1-column {.cls ohvbd.data.frame}.")
  id_col_name <- switch(ohvbd_db(dataset),
                        "vt" = "DatasetID",
                        "vd" = "dataset_id",
                        "dataset_id_col_name"

  )
  dataset_df <- data.frame(dataset)
  colnames(dataset_df) <- id_col_name
  dataset_df <- new_ohvbd.data.frame(dataset_df, ohvbd_db(dataset))

  fetch_citations.ohvbd.data.frame(dataset_df, ...)
}

#' @export
fetch_citations.ohvbd.data.frame <- function(
  dataset,
  ...
) {
  .args <- list(...)
  db <- .args$db
  if (is.null(db)) {
    # If not overriding database, just use the one provided
    db <- ohvbd_db(dataset) %||%
      cli::cli_abort(
        c(
          "x" = "No database attached to the dataset and none specified!",
          "i" = "Either specify using the {.arg db} argument, or use {.fn ohvbd::force_db}"
        )
      )
  }
  .args$db <- NULL

  if (!has_db(dataset)) {
    dataset <- force_db(dataset, db)
  }

  finalfun <- switch(
    db,
    "vt" = fetch_citations_vt,
    "vd" = fetch_citations_vd,
    # "gbif" = fetch_citations_gbif,
    cli::cli_abort(
      "No method to extract citations from {.val {db}} for class{?es} {.cls {class(x)}}"
    )
  )
  .args$dataset <- dataset
  return(do.call(finalfun, .args))
}

#' @title Database provenance
#'
#' @description
#' Retrieve or set the provenance information expected by `ohvbd`.
#'
#'
#' @author Francis Windram
#'
#' @param x An object.
#'
#' @returns The database identifier associated with an object (or `NULL` if missing).
#' @concept convenience
#' @examples
#' ids <- ohvbd.ids(c(1,2,3), "vd")
#' ohvbd_db(ids)
#'
#' ohvbd_db(ids) <- "vt"
#' ohvbd_db(ids)
#'
#' @seealso [Internal attributes][ohvbd_attrs]
#'
#' @name ohvbd_db
NULL


#' @rdname ohvbd_db
#' @export
ohvbd_db <- function(x) {
  UseMethod("ohvbd_db")
}

#' @export
ohvbd_db.default <- function(x) {
  attr(x, "db", exact = TRUE)
}

#' @rdname ohvbd_db
#' @param value The value to set the db to.
#' @export
`ohvbd_db<-` <- function(x, value) {
  UseMethod("ohvbd_db<-")
}

#' @export
`ohvbd_db<-.default` <- function(x, value) {
  attr(x, "db") <- value
  x
}

#' @title Test whether an object has provenance information
#'
#' @description
#' This function tests whether an object has the provenance information expected by `ohvbd`.
#'
#' @author Francis Windram
#'
#' @param x An object to test.
#' @param ... Any arguments to be passed to the underlying functions (unused).
#'
#' @returns Whether the data has a provenance tag (as a boolean).
#' @concept convenience
#' @export
#' @examples
#' ids <- ohvbd.ids(c(1,2,3), "vd")
#' has_db(ids)
#'
has_db <- function(x, ...) {
  UseMethod("has_db")
}

#' @export
has_db.default <- function(x, ...) {
  !is.null(ohvbd_db(x))
}

#' @title Test whether an object is considered to be from a particular database
#'
#' @description
#' This function tests whether an object is considered (by `ohvbd`) to be from a given database.
#'
#' This is a fairly coarse check, and so cannot "work out" data provenance from its structure.
#' @author Francis Windram
#'
#' @param x An object to test.
#' @param db The database to test against.
#' @param ... Any arguments to be passed to the underlying functions (unused).
#'
#' @returns Whether the data is from a given database (as a boolean).
#' @concept convenience
#' @export
#' @examples
#' ids <- ohvbd.ids(c(1,2,3), "vd")
#' is_from(ids, "vd")
#'
is_from <- function(x, db, ...) {
  UseMethod("is_from")
}

#' @export
is_from.default <- function(x, db, ...) {
  ohvbd_db(x) %||% FALSE == db
}

# nolint end