R/local-collections.R

In TKCat: Tailored Knowledge Catalog

###############################################################################@
#' Import a  the definition of a collection of concepts in the local environment
#'
#' @param txt a JSON string or file
#' @param overwrite a single logical. If TRUE the collection is overwritten
#' if it already exists (default: FALSE)
#'
#' @return No return value, called for side effects. The collection will be
#' available and operations will be possible on its members.
#'
#' @export
#'
import_local_collection <- function(txt, overwrite = FALSE) {
  if (file.exists(txt)) {
    raw <- readLines(txt) |> paste(collapse = "\n")
  } else {
    raw <- txt
  }

  if (
    !jsonvalidate::json_validate(
      raw,
      tkcatEnv$COL_SCHEMA,
      verbose = TRUE,
      engine = "ajv"
    )
  ) {
    stop("Not a valid collection")
  }
  def <- jsonlite::fromJSON(raw)
  if (
    def$properties$collection$enum %in%
      list_local_collections()$title &&
      !overwrite
  ) {
    stop(
      sprintf(
        'A "%s" has already been imported.',
        def$properties$collection$enum
      ),
      " Set overwrite to TRUE if you want to replace it."
    )
  }
  assign(
    x = "COLLECTIONS",
    value = tkcatEnv$COLLECTIONS |>
      dplyr::filter(.data$title != def$properties$collection$enum) |>
      dplyr::bind_rows(dplyr::tibble(
        title = def$properties$collection$enum,
        description = def$description,
        json = raw
      )),
    envir = tkcatEnv
  )
  invisible()
}


###############################################################################@
#' List local collections of concepts
#'
#' @param withJson if TRUE, returns the json strings of the collection
#' (default: FALSE)
#'
#' @return A tibble with the title, the description and optionally the json
#' definition of the collections
#'
#' @export
#'
list_local_collections <- function(withJson = FALSE) {
  toRet <- tkcatEnv$COLLECTIONS
  if (!withJson) {
    toRet <- dplyr::select(toRet, "title", "description")
  }
  return(toRet)
}


###############################################################################@
#' Get the json definition of a local collection of concepts
#'
#' @param title the title of the collection to get
#'
#' @return The definition of the collection as a JSON string.
#'
#' @export
#'
get_local_collection <- function(title) {
  if (!title %in% list_local_collections()$title) {
    stop("This collection is not available")
  }
  tkcatEnv$COLLECTIONS |>
    dplyr::filter(.data$title == !!title) |>
    dplyr::pull("json")
}


###############################################################################@
#' Import a  function to map collection members
#'
#' @param collection the name of the targeted collection
#' (it should belong to local collections: see [list_local_collections()]).
#' @param fun a function which takes 2 data.frames (x an y) with
#' fields described in the collection definition and map the different elements.
#'
#' @return No return value, called for side effects. The function will be used
#' to map collection members.
#'
#' @export
#'
import_collection_mapper <- function(collection, fun) {
  stopifnot(
    is.function(fun),
    c("x", "y", "...") %in% names(formals(fun)),
    collection %in% list_local_collections()$title
  )
  toAdd <- list(fun)
  names(toAdd) <- collection
  assign(
    x = "MAPPERS",
    value = c(tkcatEnv$MAPPERS, toAdd),
    envir = tkcatEnv
  )
  invisible()
}


###############################################################################@
#' Get the default mapper function for a collection
#'
#' @param collection the name of the targeted collection
#' (it should belong to local collections: see [list_local_collections()]).
#'
#' @return A function to map collection members.
#'
#' @export
#'
get_collection_mapper <- function(collection) {
  get("MAPPERS", envir = tkcatEnv)[[collection]]
}

###############################################################################@
#' Map different collection members
#'
#' @param x a data.frame
#' @param y a data.frame
#' @param collection the name of the collection.
#' @param xm collection member x: a data.frame with the fields
#' "field", "static", "value", "type" as returned by
#' the [read_collection_members()] function.
#' @param ym collection member y: a data.frame with the fields
#' "field", "static", "value", "type" as returned by
#' the [read_collection_members()] function.
#' @param suffix the suffix to append to field names from x and y tables.
#' Default: `c("_x", "_y")`
#' @param fun the function used to map x and y collection members.
#' By default (NA) it is automatically identified if recorded in the system.
#' The way to write this function is provided in the details section.
#' @param ... additional parameters for the fun function.
#'
#' @details fun must have at least an x and a y parameters.
#' Each of them should be a data.frame with all the field values
#' given in xm and ym. Additional parameters
#' can be defined and will be forwarded using `...`.
#' fun should return a data frame with all the fields values
#' given in xm and ym followed by "_x" and "_y" suffix.
#'
#' @return A tibble giving necessary information to map elements in x and y.
#' The columns corresponds to the field values in xm and ym followed by a
#' suffix (default: `c("_x", "_y")`). Only fields documented as non static
#' in xm and ym are kept.
#'
#' @export
#'
map_collection_members <- function(
  x,
  y,
  collection,
  xm,
  ym,
  suffix = c("_x", "_y"),
  fun = NA,
  ...
) {
  stopifnot(
    all(xm$value[which(!xm$static)] %in% colnames(x)),
    all(ym$value[which(!ym$static)] %in% colnames(y))
  )
  if (!is.function(fun) && !is.na(fun)) {
    stop("fun should be NA or a function")
  }
  if (!is.function(fun)) {
    fun <- get_collection_mapper(collection = collection)
  }

  ## Prepare for conversion ----
  ## x
  xp <- dplyr::select(
    x,
    dplyr::all_of(xm$value[which(!xm$static)])
  ) |>
    .set_colnames(xm$field[which(!xm$static)])
  for (i in 1:nrow(xm)) {
    f <- xm$field[i]
    if (xm$static[i]) {
      xp[, f] <- xm$value[i]
    }
    if (!is.na(xm$type[i])) {
      xp[, paste0(f, "_type")] <- xm$type[i]
    }
  }
  ## y
  yp <- dplyr::select(
    y,
    dplyr::all_of(ym$value[which(!ym$static)])
  ) |>
    .set_colnames(ym$field[which(!ym$static)])
  for (i in 1:nrow(ym)) {
    f <- ym$field[i]
    if (ym$static[i]) {
      yp[, f] <- ym$value[i]
    }
    if (!is.na(ym$type[i])) {
      yp[, paste0(f, "_type")] <- ym$type[i]
    }
  }

  ## Conversion ----
  toRet <- dplyr::as_tibble(fun(xp, yp, ...))
  stopifnot(all(
    c(paste0(xm$field, "_x"), paste0(ym$field, "_y")) %in%
      colnames(toRet)
  ))

  ## Post-processing ----
  toKeep <- c(
    paste0(xm$value, suffix[1])[which(!xm$static)],
    paste0(ym$value, suffix[2])[which(!ym$static)]
  ) |>
    rlang::set_names(c(
      paste0(xm$field, "_x")[which(!xm$static)],
      paste0(ym$field, "_y")[which(!ym$static)]
    ))
  toRet <- dplyr::select(toRet, dplyr::all_of(names(toKeep)))
  colnames(toRet) <- toKeep[colnames(toRet)]

  return(toRet)
}