R/MDB.R

In TKCat: Tailored Knowledge Catalog

###############################################################################@
#' MDB
#'
#' The class "MDB" provides general functions for handling
#' modeled databases.
#' The MDB classes implemented in the TKCat package
#' are: [fileMDB], [memoMDB], chMDB and [metaMDB].
#' These classes provide additional functions.
#'
#' @seealso MDB methods:
#' [db_info], [data_model], [data_tables], [collection_members],
#' [count_records], [filter_with_tables], [as_fileMDB]
#' Additional documentation is provided for each specific class:
#' [fileMDB], [memoMDB], chMDB and [metaMDB].
#'
#' @name MDB
#'
NULL


###############################################################################@
#' Check if the object is an [MDB] object
#'
#' @param x any object
#'
#' @return A single logical: TRUE if x is an MDB object.
#'
#' @export
#'
is.MDB <- function(x) {
  inherits(x, "MDB")
}


###############################################################################@
#'
#' @param x an MDB object
#'
#' @return  `names()` returns the table names.
#'
#' @rdname MDB
#'
#' @export
#'
names.MDB <- function(x) {
  names(data_model(x))
}


###############################################################################@
#'
#' @param x an MDB object
#'
#' @return `length()` returns the number of tables in x.
#'
#' @rdname MDB
#'
#' @export
#'
length.MDB <- function(x) {
  length(data_model(x))
}


###############################################################################@
#'
#' @rdname count_records
#' @method count_records MDB
#'
#' @export
#'
count_records.MDB <- function(x, ...) {
  d <- dims(x, ...)
  d$records |> rlang::set_names(d$name)
}


###############################################################################@
#'
#' @param x an MDB object
#' @param use.names return the names of the tables
#'
#' @return `lengths()` returns the number of fields for each table in x.
#'
#' @rdname MDB
#'
#' @export
#'
lengths.MDB <- function(x, use.names = TRUE) {
  lengths(data_model(x), use.names = use.names)
}


###############################################################################@
#' @export
#'
format.MDB <- function(x, ...) {
  cm <- collection_members(x)
  dbi <- db_info(x)
  maintainer <- db_info(x)$maintainer
  return(sprintf(
    paste(
      "%s %s%s%s",
      "   - %s tables with %s fields",
      "",
      "%s",
      "",
      "%s",
      "%s",
      "%s",
      "",
      sep = "\n"
    ),
    class(x)[1],
    db_info(x)$name,
    ifelse(
      (is.na(dbi$version) || dbi$version == "") &&
        (is.na(dbi$maintainer) || dbi$maintainer == ""),
      "",
      sprintf(
        " (%s%s%s)",
        ifelse(
          is.na(dbi$version) || dbi$version == "",
          "",
          sprintf('version %s', dbi$version)
        ),
        ifelse(
          !is.na(dbi$version) &&
            dbi$version != "" &&
            !is.na(dbi$maintainer) &&
            dbi$maintainer != "",
          ', ',
          ''
        ),
        ifelse(
          is.na(dbi$maintainer) || dbi$maintainer == "",
          "",
          dbi$maintainer
        )
      )
    ),
    ifelse(
      is.na(dbi$title) || dbi$title == "",
      '',
      sprintf(': %s', dbi$title)
    ),
    length(x),
    sum(lengths(x)),
    if (!is.null(cm) && nrow(cm) > 0) {
      sprintf(
        "Collection members: \n%s",
        paste(
          unlist(lapply(
            unique(cm$collection),
            function(y) {
              return(sprintf(
                "   - %s %s member%s",
                length(unique(cm$mid[which(cm$collection == y)])),
                y,
                ifelse(
                  length(unique(cm$mid[which(cm$collection == y)])) > 1,
                  "s",
                  ""
                )
              ))
            }
          )),
          collapse = "\n"
        )
      )
    } else {
      "No collection member"
    },
    ifelse(
      is.na(dbi$description) || dbi$description == "",
      '',
      dbi$description
    ),
    ifelse(
      is.na(dbi$url) || dbi$url == "",
      '',
      sprintf('(%s)', dbi$url)
    ),
    ifelse(
      is.na(dbi$timestamp),
      '',
      sprintf('\nTimestamp: %s', dbi$timestamp)
    )
  ))
}


###############################################################################@
#' @export
#'
print.MDB <- function(x, ...) {
  cat(format(x, ...), "\n")
}


###############################################################################@
#'
#' @param x an MDB object
#' @param ... additional parameters
#'
#' @return `as.list.MDB()` returns a simple list of tibbles with all the
#' data from the tables in x.
#'
#' @rdname MDB
#'
#' @export
#'
as.list.MDB <- function(x, ...) {
  data_tables(x, ...)
}


###############################################################################@
#' @export
#'
str.MDB <- function(object, ...) {
  utils::str(unclass(object))
}


###############################################################################@
#'
#' @param .data an MDB object
#' @param ... additional parameters
#'
#' @rdname MDB
#'
#' @export
#'
select.MDB <- function(.data, ...) {
  i <- tidyselect::eval_select(rlang::expr(c(...)), .data)
  .data[i]
}


###############################################################################@
#'
#' @param .data an MDB object
#' @param var a variable specified as in [dplyr::pull]
#' @param name not used but kept for compatibility with the generic function
#' @param ... additional parameters
#'
#' @rdname MDB
#'
#' @export
#'
pull.MDB <- function(.data, var = -1, name = NULL, ...) {
  if (!is.null(name)) {
    warning("name parameter not used by the pull.MDB function")
  }
  var <- tidyselect::vars_pull(names(.data), !!rlang::enquo(var))
  return(.data[[var]])
}


###############################################################################@
#' Add a collection member to an MDB
#'
#' @param x an [MDB] object
#' @param collection a collection title in [list_local_collections()]
#' @param table the table providing the collection member
#' @param ... definition of the collection fields as lists
#' (e.g. `be=list(static=TRUE, value="Gene")`
#' or
#' `organism=list(static=TRUE, value="Homo sapiens", type="Scientific name")`
#' )
#'
#' @export
#'
add_collection_member <- function(
  x,
  collection,
  table,
  ...
) {
  fd <- list(...)
  stopifnot(
    is.MDB(x),
    is.character(collection),
    length(collection) == 1,
    !is.na(collection),
    collection %in% list_local_collections()$title,
    is.character(table),
    length(table) == 1,
    !is.na(table),
    table %in% names(x),
    length(fd) > 0,
    length(names(fd)) == length(fd),
    all(unlist(lapply(
      fd,
      function(y) {
        all(names(y) %in% c("static", "value", "type")) &&
          all(c("value", "static") %in% names(y))
      }
    )))
  )
  resource <- db_info(x)$name
  cm <- collection_members(x)
  if (!is.null(cm) && nrow(cm) > 0) {
    if (collection %in% cm$collection) {
      cid <- cm$cid[which(cm$collection == collection)][1]
      mid <- max(cm$mid[which(cm$collection == collection)]) + 1
    } else {
      cid <- paste(resource, collection, "1.0", sep = "_")
      mid <- 1
    }
  } else {
    cid <- paste(resource, collection, "1.0", sep = "_")
    mid <- 1
  }
  toAdd <- c()
  for (field in names(fd)) {
    def <- fd[[field]]
    toAdd <- rbind(
      toAdd,
      dplyr::tibble(
        field = field,
        static = def[["static"]],
        value = def[["value"]],
        type = ifelse(
          length(def[["type"]]) != 1,
          as.character(NA),
          def[["type"]]
        )
      )
    )
  }
  toAdd$collection <- collection
  toAdd$cid <- cid
  toAdd$resource <- resource
  toAdd$mid <- as.integer(mid)
  toAdd$table <- table
  toAdd <- dplyr::select(
    toAdd,
    "collection",
    "cid",
    "resource",
    "mid",
    "table",
    "field",
    "static",
    "value",
    "type"
  )
  if (!is.null(cm)) {
    alreadyIn <- sharedFields <- FALSE
    for (cmmid in unique(cm$mid)) {
      toAddf <- dplyr::inner_join(
        toAdd,
        cm[which(cm$mid == cmmid), ],
        by = c("collection", "table", "field", "value")
      )
      alreadyIn <- alreadyIn || nrow(toAddf) == nrow(toAdd)
      sharedFields <- sharedFields || nrow(toAddf) > 0
    }
    if (alreadyIn) {
      warning(
        "Member already recorded: it won't be added nor modified"
      )
      toAdd <- NULL
    } else {
      if (sharedFields) {
        warning(
          "Members share fields"
        )
      }
    }
  }
  cm <- rbind(
    cm,
    toAdd
  )
  toRet <- x
  collection_members(toRet) <- cm
  return(toRet)
}

###############################################################################@
#' Compare two MDB objects
#'
#' @param former an MDB object
#' @param new an MDB object
#'
#' @return A tibble with 4 columns:
#' - **Information**: Compared information
#' - **Former**: value for the former object
#' - **New**: value for the new object
#' - **Identical**: a logical indicating if the 2 values are identical
#'
#' @export
#'
compare_MDB <- function(former, new) {
  stopifnot(is.MDB(former), is.MDB(new))

  ## DB information ----
  fdbi <- db_info(former)
  ndbi <- db_info(new)
  dbif <- union(names(fdbi), names(ndbi))
  toRet <- dplyr::tibble(
    "Information" = dbif,
    "Former" = unlist(fdbi)[dbif],
    "New" = unlist(ndbi)[dbif]
  ) |>
    dplyr::mutate(
      "Identical" = .data$Former == .data$New
    )

  ## Data model ----
  toRet <- dplyr::bind_rows(
    toRet,
    dplyr::tibble(
      "Information" = c("Model", "Model display"),
      "Former" = c(sprintf("%s tables", length(former)), ""),
      "New" = c(sprintf("%s tables", length(new)), ""),
      "Identical" = c(
        ReDaMoR::identical_RelDataModel(
          data_model(former),
          data_model(new),
          includeDisplay = FALSE
        ),
        ReDaMoR::identical_RelDataModel(
          data_model(former),
          data_model(new),
          includeDisplay = TRUE
        )
      )
    )
  )

  ## Records ----
  fnr <- count_records(former)
  fnr <- fnr[sort(names(fnr))]
  nnr <- count_records(new)
  nnr <- nnr[sort(names(nnr))]
  if (
    length(fnr) == length(nnr) &&
      length(fnr) > 0 &&
      all(names(fnr) == names(nnr))
  ) {
    toRet <- dplyr::bind_rows(
      toRet,
      dplyr::tibble(
        "Information" = c(sprintf("Table %s", names(fnr)), "Total"),
        "Former" = format(c(fnr, sum(fnr)), big.mark = ",", trim = FALSE),
        "New" = format(c(nnr, sum(nnr)), big.mark = ",", trim = FALSE)
      ) |>
        dplyr::mutate(
          "Identical" = c(fnr, sum(fnr)) == c(nnr, sum(nnr))
        )
    )
  }

  ## Collection members ----
  ccm <- collection_members(former)
  if (!is.null(ccm)) {
    ccm <- ccm |> dplyr::select(-"resource") |> dplyr::arrange_all()
    ccoll <- ccm |>
      dplyr::distinct(
        .data$collection,
        .data$table,
        .data$mid
      ) |>
      nrow()
  } else {
    ccoll <- 0
  }
  ncm <- collection_members(new)
  if (!is.null(ncm)) {
    ncm <- ncm |> dplyr::select(-"resource") |> dplyr::arrange_all()
    ncoll <- ncm |>
      dplyr::distinct(
        .data$collection,
        .data$table,
        .data$mid
      ) |>
      nrow()
  } else {
    ncoll <- 0
  }
  toRet <- dplyr::bind_rows(
    toRet,
    dplyr::tibble(
      "Information" = "Collections",
      "Former" = format(ccoll, big.mark = ",", trim = FALSE),
      "New" = format(ncoll, big.mark = ",", trim = FALSE),
      "Identical" = (ccoll == ncoll && (ccoll == 0 || identical(ccm, ncm)))
    )
  )

  return(toRet)
}

###############################################################################@
#' @export
#'
`[<-.MDB` <- function(x, i, value) {
  stop("'[<-' is not supported for MDB")
}

###############################################################################@
#' @export
#'
`[[<-.MDB` <- function(x, i, value) {
  stop("'[[<-' is not supported for MDB")
}

###############################################################################@
#' @export
#'
`$<-.MDB` <- function(x, i, value) {
  stop("'$<-' is not supported for MDB")
}


###############################################################################@
#'
#' @param ... [MDB] objects
#'
#' @rdname MDB
#'
#' @export
#'
c.MDB <- function(...) {
  MDBs <- list(...)
  dbNames <- unlist(lapply(
    MDBs,
    function(x) db_info(x)$name
  ))
  if (any(duplicated(dbNames))) {
    stop("MDBs to combine cannot have the same names")
  }
  names(MDBs) <- dbNames
  dbModels <- lapply(MDBs, data_model) |>
    rlang::set_names(NULL)
  dataModel <- do.call(c, dbModels)
  return(metaMDB(
    MDBs = MDBs,
    relationalTables = NULL,
    dataModel = dataModel,
    dbInfo = db_info(MDBs[[1]]),
    check = FALSE
  ))
}


##############################################################################@
#' Merge 2 MDBs
#'
#' @param x an MDB object
#' @param y an MDB object
#' @param by a tibble as returned by the [get_shared_collections()] function
#' which indicates which collection members should be merged through
#' a relational table. If the collection is `NA`, the relational table is built
#' by merging identical columns in table.x and table.y. If the collection
#' is provided, the relational table is build using
#' the [map_collection_members()] function.
#' @param dbInfo a list with DB information:
#' **"name"** (only mandatory field), "title", "description", "url",
#' "version", "maintainer".
#' @param dmAutoLayout if TRUE (default) the layout of the merged data model
#' is automatically adjusted.
#' @param rtColor the color of the relational tables in the merged data model
#' (default: "yellow")
#' @param funs a named list of functions (default: list()). If there is
#' no function for mapping a collection in this list, it is taken
#' automatically using the [get_collection_mapper()] function.
#' @param ... additional parameters
#'
#' @return A [metaMDB] object gathering x and y along
#' with relational tables between them created using collection members
#' and mapping functions automatically chosen or provided by
#' the `funs` parameter. `...` can be used to send parameters to the mapper
#' functions.
#'
#' @rdname MDB
#'
#' @export
#'
merge.MDB <- function(
  x,
  y,
  by = get_shared_collections(x, y),
  dbInfo = list(name = paste(db_info(x)$name, db_info(y)$name, sep = "_")),
  dmAutoLayout = TRUE,
  rtColor = "yellow",
  funs = list(),
  ...
) {
  ## Checks ----
  stopifnot(
    is.MDB(x),
    is.MDB(y),
    is.data.frame(by),
    nrow(by) > 0,
    all(
      c("collection", "mid.x", "table.x", "mid.y", "table.y") %in%
        colnames(by)
    )
  )
  by <- dplyr::distinct(by)
  ic <- dplyr::setdiff(by, get_shared_collections(x, y))
  if (nrow(ic) > 0) {
    if (any(!is.na(ic$collection))) {
      print(ic)
      stop("Cannot merge using the provided collection members")
    }
    mt <- setdiff(c(ic$table.x, ic$table.y), c(names(x), names(y)))
    if (length(mt) > 0) {
      stop(
        "The following tables do not exist: ",
        paste(mt, collapse = ", ")
      )
    }
  }
  dbInfo <- .check_dbInfo(dbInfo)

  ## Building the relational tables ----
  by <- by |>
    dplyr::mutate(
      rt = ifelse(
        !is.na(.data$collection),
        paste(
          .data$collection,
          .data$mid.x,
          .data$table.x,
          .data$mid.y,
          .data$table.y,
          sep = "_"
        ),
        paste(
          .data$table.x,
          .data$table.y,
          sep = "_"
        )
      )
    )
  xcm <- collection_members(x)
  ycm <- collection_members(y)
  relationalTables <- list()
  dm <- c(data_model(x), data_model(y))
  fdm <- unclass(dm)
  for (i in 1:nrow(by)) {
    byi <- by[i, ]

    ##
    if (is.na(byi$collection)) {
      tmx <- dm[[byi$table.x]]$fields
      tmy <- dm[[byi$table.y]]$fields
      tmxy <- dplyr::intersect(
        dplyr::select(tmx, "name", "type"),
        dplyr::select(tmy, "name", "type")
      )
      if (nrow(tmxy) == 0) {
        stop(
          "There is no common field with the same type in",
          sprintf(
            " the provided tables: %s and %s",
            byi$table.x,
            byi$table.y
          )
        )
      }
      tmxy$nullable <- tmx$nullable[match(tmxy$name, tmx$name)] |
        tmy$nullable[match(tmxy$name, tmy$name)]
      tmxy$unique <- tmx$unique[match(tmxy$name, tmx$name)] &
        tmy$unique[match(tmxy$name, tmy$name)]
      tmxy$comment <- as.character(NA)

      relationalTables[[byi$rt]] <- dplyr::bind_rows(
        x[[byi$table.x]][, tmxy$name],
        y[[byi$table.y]][, tmxy$name],
      ) |>
        dplyr::distinct()

      tm <- ReDaMoR::RelTableModel(
        tableName = byi$rt,
        fields = tmxy,
        primaryKey = NULL,
        foreignKeys = list(
          list(
            refTable = byi$table.x,
            key = dplyr::tibble(
              from = tmxy$name,
              to = tmxy$name
            ),
            cardinality = c(fmin = 0L, fmax = -1L, tmin = 0L, tmax = -1L)
          ),
          list(
            refTable = byi$table.y,
            key = dplyr::tibble(
              from = tmxy$name,
              to = tmxy$name
            ),
            cardinality = c(fmin = 0L, fmax = -1L, tmin = 0L, tmax = -1L)
          )
        ),
        indexes = NULL,
        "display" = list(
          x = as.numeric(NA),
          y = as.numeric(NA),
          color = rtColor,
          comment = as.character(NA)
        )
      )
    } else {
      xcmi <- xcm |>
        dplyr::filter(
          .data$collection == byi$collection,
          .data$mid == byi$mid.x,
          .data$table == byi$table.x
        ) |>
        dplyr::select("field", "static", "value", "type")
      ycmi <- ycm |>
        dplyr::filter(
          .data$collection == byi$collection,
          .data$mid == byi$mid.y,
          .data$table == byi$table.y
        ) |>
        dplyr::select("field", "static", "value", "type")

      dxcmi <- xcmi |>
        dplyr::filter(!.data$static) |>
        dplyr::select("name" = "value") |>
        dplyr::left_join(dm[[byi$table.x]]$fields, by = "name") |>
        dplyr::rename("to" = "name") |>
        dplyr::mutate(
          name = paste(.data$to, byi$table.x, sep = "_"),
          nullable = TRUE,
          unique = FALSE,
          refTable = byi$table.x
        )
      dycmi <- ycmi |>
        dplyr::filter(!.data$static) |>
        dplyr::select("name" = "value") |>
        dplyr::left_join(dm[[byi$table.y]]$fields, by = "name") |>
        dplyr::rename("to" = "name") |>
        dplyr::mutate(
          name = paste(.data$to, byi$table.y, sep = "_"),
          nullable = TRUE,
          unique = FALSE,
          refTable = byi$table.y
        )
      tm <- ReDaMoR::RelTableModel(
        tableName = byi$rt,
        fields = dplyr::bind_rows(
          dplyr::select(
            dxcmi,
            "name",
            "type",
            "nullable",
            "unique",
            "comment"
          ),
          dplyr::select(
            dycmi,
            "name",
            "type",
            "nullable",
            "unique",
            "comment"
          )
        ),
        primaryKey = NULL,
        foreignKeys = list(
          list(
            refTable = byi$table.x,
            key = dplyr::tibble(
              from = dxcmi$name,
              to = dxcmi$to
            ),
            cardinality = c(fmin = 0L, fmax = -1L, tmin = 0L, tmax = -1L)
          ),
          list(
            refTable = byi$table.y,
            key = dplyr::tibble(
              from = dycmi$name,
              to = dycmi$to
            ),
            cardinality = c(fmin = 0L, fmax = -1L, tmin = 0L, tmax = -1L)
          )
        ),
        indexes = NULL,
        "display" = list(
          x = as.numeric(NA),
          y = as.numeric(NA),
          color = rtColor,
          comment = as.character(NA)
        )
      )

      ## The relational table
      nrt <- map_collection_members(
        x = x[[byi$table.x]],
        y = y[[byi$table.y]],
        collection = byi$collection,
        xm = xcmi,
        ym = ycmi,
        suffix = paste0("_", c(byi$table.x, byi$table.y)),
        fun = if (
          is.null(funs[[byi$collection]]) ||
            !is.function(funs[[byi$collection]])
        ) {
          NA
        } else {
          funs[[byi$collection]]
        },
        ...
      )

      cc <- unlist(lapply(nrt, function(x) class(x)[1]))
      fcc <- dplyr::mutate(tm$fields, cc = cc[.data$name])
      wc <- dplyr::filter(fcc, .data$type != .data$cc) |> dplyr::pull("name")

      for (cn in wc) {
        nrt[, cn] <- ReDaMoR::as_type(
          dplyr::pull(nrt, !!cn),
          tm$fields$type[which(tm$fields$name == cn)]
        )
      }
      relationalTables[[byi$rt]] <- nrt
    }

    fdm[[byi$rt]] <- tm
  }
  dm <- ReDaMoR::RelDataModel(fdm)

  ## Final object ----
  if (dmAutoLayout) {
    dm <- ReDaMoR::auto_layout(dm)
  }

  return(metaMDB(
    MDBs = list(x, y) |>
      rlang::set_names(c(db_info(x)$name, db_info(y)$name)),
    relationalTables = relationalTables,
    dataModel = dm,
    dbInfo = dbInfo
  ))
}


##############################################################################@
#' Join connected tables
#'
#' @param x an MDB object
#' @param ... at least 2 names of tables to join
#' @param type the type of join among:
#' - `"left"`: includes all rows of the first provided table
#' - `"right"`: includes all rows of the last provided table
#' - `"inner"`: includes all rows in all provided tables
#' - `"full"`: includes all rows in at least one provide table
#' @param jtName the name of the joint table. If NA (default), it is
#' the first provided table name.
#'
#' @return A [metaMDB] corresponding to x with the
#' joined tables replaced by the joint.
#' If less than 2 table names are provided, the function returns
#' the original x MDB.
#'
#' @export
#'
join_mdb_tables <- function(
  x,
  ...,
  type = c("left", "right", "inner", "full"),
  jtName = NA
) {
  stopifnot(
    is.MDB(x)
  )
  ttj <- as.character(c(...)) # tables to join
  if (any(duplicated(ttj))) {
    dupttj <- unique(ttj[which(duplicated(ttj))])
    warning(sprintf(
      "Table%s '%s' %s going to be joined several times",
      ifelse(length(dupttj) > 1, "s", ""),
      paste(dupttj, collapse = "', '"),
      ifelse(length(dupttj) > 1, "are", "is")
    ))
  }
  if (!all(ttj %in% names(x))) {
    stop("Tables not found: ", setdiff(ttj, names(x)))
  }
  type <- match.arg(type)
  jfun <-
    if (type == "left") {
      dplyr::left_join
    } else if (type == "right") {
      dplyr::right_join
    } else if (type == "inner") {
      dplyr::inner_join
    } else if (type == "full") {
      dplyr::full_join
    }

  ## Simple case ----
  if (length(ttj) < 2) {
    return(x)
  }

  ## Join table name ----
  if (is.na(jtName)) {
    jtName <- ttj[1]
  }
  if (jtName %in% setdiff(names(x), ttj)) {
    stop("Wrong jtName: this name will still be used after the join.")
  }
  techname <- paste0("T", sample.int(10^6, 1), "T")
  while (techname %in% names(x)) {
    techname <- paste0("T", sample.int(10^6, 1), "T")
  }

  ## Join the 2 first tables ----

  ## _+ Subset tables ----
  toJoin <- ttj[1:2]
  ttj <- ttj[-(1:2)]
  rx <- x[union(setdiff(names(x), toJoin), ttj)]

  ## _+ Check foreign keys ----
  dm <- data_model(x)
  fk <- ReDaMoR::get_foreign_keys(dm)
  fkt <- dplyr::bind_rows(
    dplyr::filter(
      fk,
      .data$from == !!toJoin[1] & .data$to == !!toJoin[2]
    ),
    dplyr::filter(
      fk,
      .data$from == !!toJoin[2] & .data$to == !!toJoin[1]
    ) |>
      dplyr::rename(
        "to" = "from",
        "tf" = "ff",
        "from" = "to",
        "ff" = "tf",
        "tmin" = "fmin",
        "tmax" = "fmax",
        "fmin" = "tmin",
        "fmax" = "tmax"
      )
  )
  if (nrow(fkt) == 0) {
    stop(sprintf("There is no relationship with %s", toJoin[2]))
  }

  ## _+ Set suffix for ambiguous fields ----
  if (nrow(fkt) == 1) {
    fkt$suffix <- ""
  } else {
    ff <- unlist(lapply(fkt$ff, function(x) paste(sort(x), collapse = "_")))
    if (!any(duplicated(ff))) {
      fkt$suffix <- ff
    } else {
      tf <- unlist(lapply(fkt$tf, function(x) paste(sort(x), collapse = "_")))
      if (!any(duplicated(tf))) {
        fkt$suffix <- tf
      } else {
        fftf <- paste(ff, tf, sep = "__")
        if (!any(duplicated(fftf))) {
          fkt$suffix <- fftf
        } else {
          fkt$suffix <- paste(fftf, 1:length(fftf), sep = "__")
        }
      }
    }
  }

  ## _+ Initiate the new data model ----
  jt <- x[[toJoin[1]]]
  jdm <- data_model(rx)
  toAdd <- dm[toJoin[1], rmForeignKeys = TRUE][[1]]
  toAdd$tableName <- techname
  toAdd$fields <- toAdd$fields |>
    dplyr::mutate(
      nullable = TRUE,
      unique = FALSE
    )
  toAdd$primaryKey <- character()
  toAdd$indexes <- list()
  toAdd <- list(toAdd) |> rlang::set_names(techname)
  toAdd <- ReDaMoR::RelDataModel(toAdd)
  jdm <- c(jdm, toAdd)
  fkToAdd <- dplyr::bind_rows(
    dplyr::filter(
      fk,
      .data$from == !!toJoin[1] & .data$to %in% names(rx)
    ) |>
      dplyr::mutate(from = techname, fmin = 0L, fmax = -1L),
    dplyr::filter(
      fk,
      .data$from %in% names(rx) & .data$to == !!toJoin[1]
    ) |>
      dplyr::mutate(to = techname, tmin = 0L, tmax = -1L)
  )
  if (nrow(fkToAdd) > 0) {
    for (j in 1:nrow(fkToAdd)) {
      fkj <- dplyr::slice(fkToAdd, j)
      jdm <- ReDaMoR::add_foreign_key(
        jdm,
        fromTable = dplyr::pull(fkj, "from"),
        fromFields = dplyr::pull(fkj, "ff")[[1]],
        toTable = dplyr::pull(fkj, "to"),
        toFields = dplyr::pull(fkj, "tf")[[1]],
        fmin = dplyr::pull(fkj, "fmin"),
        fmax = dplyr::pull(fkj, "fmax"),
        tmin = dplyr::pull(fkj, "tmin"),
        tmax = dplyr::pull(fkj, "tmax")
      )
    }
  }

  ## _+ Join the tables ----
  t2 <- x[[toJoin[2]]]
  for (i in 1:nrow(fkt)) {
    t2i <- t2
    cn <- setdiff(colnames(t2i), fkt$tf[[i]])
    if (fkt$suffix[[i]] == "") {
      nn <- cn
    } else {
      nn <- paste(cn, fkt$suffix[[i]], sep = ".")
    }
    if (any(nn %in% colnames(jt))) {
      nn <- paste(toJoin[2], nn, sep = ".")
    }
    cn <- c(cn, fkt$tf[[i]])
    nn <- c(nn, fkt$ff[[i]])
    rnv <- cn |> rlang::set_names(nn)
    t2i <- dplyr::rename(t2i, dplyr::all_of(rnv))
    jt <- jfun(jt, t2i, by = fkt$ff[[i]])

    rnv <- nn |> rlang::set_names(cn)
    toAdd <- dm[[toJoin[2]]]$fields |>
      dplyr::mutate(
        name = as.character(rnv[.data$name]),
        nullable = TRUE,
        unique = FALSE
      ) |>
      dplyr::filter(!.data$name %in% !!jdm[[techname]]$fields$name)
    for (j in 1:nrow(toAdd)) {
      toAddj <- dplyr::slice(toAdd, j)
      jdm <- ReDaMoR::add_field(
        jdm,
        tableName = techname,
        name = dplyr::pull(toAddj, "name"),
        type = dplyr::pull(toAddj, "type"),
        nullable = dplyr::pull(toAddj, "nullable"),
        unique = dplyr::pull(toAddj, "unique"),
        comment = dplyr::pull(toAddj, "comment")
      )
    }

    fkToAdd <- dplyr::bind_rows(
      dplyr::filter(
        fk,
        .data$from == !!toJoin[2] & .data$to %in% names(rx)
      ) |>
        dplyr::mutate(
          from = techname,
          fmin = 0L,
          fmax = -1L,
          tmin = 0L,
          tmax = -1L,
          ff = lapply(.data$ff, function(f) as.character(rnv[f]))
        ),
      dplyr::filter(
        fk,
        .data$from %in% names(rx) & .data$to == !!toJoin[2]
      ) |>
        dplyr::mutate(
          to = techname,
          tmin = 0L,
          tmax = -1L,
          fmin = 0L,
          fmax = -1L,
          tf = lapply(.data$tf, function(f) as.character(rnv[f]))
        )
    )
    if (nrow(fkToAdd) > 0) {
      for (j in 1:nrow(fkToAdd)) {
        fkj <- dplyr::slice(fkToAdd, j)
        jdm <- ReDaMoR::add_foreign_key(
          jdm,
          fromTable = dplyr::pull(fkj, "from"),
          fromFields = dplyr::pull(fkj, "ff")[[1]],
          toTable = dplyr::pull(fkj, "to"),
          toFields = dplyr::pull(fkj, "tf")[[1]],
          fmin = dplyr::pull(fkj, "fmin"),
          fmax = dplyr::pull(fkj, "fmax"),
          tmin = dplyr::pull(fkj, "tmin"),
          tmax = dplyr::pull(fkj, "tmax")
        )
      }
    }
  }

  ## metaMDB object ----
  MDBs <- list(rx) |> rlang::set_names(db_info(rx)$name)
  rt <- list(jt) |> rlang::set_names(techname)
  toRet <- metaMDB(
    MDBs = MDBs,
    relationalTables = rt,
    dataModel = jdm,
    dbInfo = db_info(x)
  )

  ## Recursion ----
  ttj <- c(techname, ttj)
  toRet <- join_mdb_tables(
    x = toRet,
    ttj,
    type = type,
    jtName = techname
  ) |>
    dplyr::rename(dplyr::all_of(rlang::set_names(techname, jtName)))
  return(toRet)
}


###############################################################################@
#' Get the last generated MDB confrontation report
#'
#' @return A confrontation report generated by [ReDaMoR::confront_data()]
#'
#' @export
#'
get_confrontation_report <- function() {
  return(tkcatEnv$confrontationReport)
}


###############################################################################@
## Helpers ----
.check_dbInfo <- function(dbInfo) {
  mandFields <- c(
    "name"
  )
  for (f in mandFields) {
    if (
      !is.character(dbInfo[[f]]) ||
        length(dbInfo[[f]]) != 1 ||
        is.na(dbInfo[[f]]) ||
        dbInfo[[f]] == ""
    ) {
      stop(sprintf(
        "%s in dbInfo should be a non-empty character",
        f
      ))
    }
  }
  optfields <- c(
    "title" = "character",
    "description" = "character",
    "url" = "character",
    "version" = "character",
    "maintainer" = "character",
    "timestamp" = "POSIXct"
  )
  for (f in names(optfields)) {
    fv <- dbInfo[[f]]
    if (length(fv) == 0) {
      if (optfields[f] == "character") {
        dbInfo[[f]] <- as.character(NA)
      }
      if (optfields[f] == "POSIXct") {
        dbInfo[[f]] <- as.POSIXct(NA)
      }
    } else {
      if (length(fv) > 1 || !is.atomic(fv)) {
        stop(sprintf("Invalid value for %s", f))
      }
      if (optfields[f] == "character") {
        dbInfo[[f]] <- as.character(fv)
      }
      if (optfields[f] == "POSIXct") {
        dbInfo[[f]] <- as.POSIXct(fv)
      }
    }
  }
  dbInfo <- as.list(dbInfo[c(mandFields, names(optfields))])
  return(dbInfo)
}

.writeDescription <- function(x, file) {
  toWrite <- jsonlite::toJSON(lapply(x, jsonlite::unbox), pretty = TRUE)
  writeLines(toWrite, file)
}

.get_virtual_tables <- function(x, ...) {
  lapply(data_model(x)[..., rmForeignKeys = TRUE], function(tm) {
    fields <- tm$fields
    if ("row" %in% fields$type) {
      to_ret <- matrix(ReDaMoR::as_type(
        c(),
        setdiff(fields$type, c("row", "column"))
      ))
    } else {
      to_ret <- do.call(
        cbind,
        apply(
          fields,
          1,
          function(f) {
            stats::setNames(
              data.frame(
                V = ReDaMoR::as_type(c(), f[2])
              ),
              f[1]
            )
          }
        )
      )
    }
    return(to_ret)
  })
}

.is_called_by_rs_function <- function() {
  calls <- sys.calls()
  any(sapply(calls, function(call) {
    fn_name <- tryCatch(
      as.character(call[[1]]),
      error = function(e) "NA"
    )
    any(
      fn_name %in%
        c(
          ".rs.rpc.get_completions",
          ".rs.getCompletionsDollar",
          ".rs.getNames",
          ".rs.getNamesImpl",
          ".rs.getCompletionType",
          ".rs.rpc.get_help",
          ".rs.getHelpRpcImpl",
          ".rs.getHelpDataFrame",
          ".rs.getAnywhere",
          ".rs.getHelpColumn",
          ".rs.getHelpColumnImpl"
        )
    )
    # if(any(grepl("^\\.rs\\.", fn_name))){
    #    print(fn_name)
    # }
    # any(grepl("^\\.rs\\.", fn_name))
  }))
}