R/RelDataModel.R

In ReDaMoR: Relational Data Modeler

###############################################################################@
#' Create a RelDataModel object
#'
#' @param l the list of table models ([RelTableModel] objects)
#' @param checkFK a logical indicating if foreign keys should be checked
#' (default: TRUE)
#' @param createFKIndex should an index be create for the foreign keys
#' (default: FALSE)
#'
#' @return A RelDataModel object.
#'
#' @export
#'
RelDataModel <- function(l, checkFK = TRUE, createFKIndex = FALSE) {
  ## Checks ----
  stopifnot(
    all(unlist(lapply(l, is.RelTableModel)))
  )

  ## Creating the object ----
  toRet <- l
  names(toRet) <- NULL
  tn <- unlist(lapply(
    toRet,
    # function(x) paste(x$dbName, x$tableName, sep=".")
    function(x) x$tableName
  ))
  dtn <- unique(tn[which(duplicated(tn))])
  if (length(dtn) > 0) {
    stop(paste(
      "Duplicated tables:",
      paste(dtn, collapse = ", ")
    ))
  }
  if (any(tn %in% PCKRESERVED)) {
    stop(sprintf("%s are reserved words", paste(PCKRESERVED, collapse = ", ")))
  }
  names(toRet) <- tn

  ## Correct constraints ----
  for (ft in names(toRet)) {
    x <- toRet[[ft]]
    if (length(x$foreignKeys) > 0) {
      for (i in 1:length(x$foreignKeys)) {
        fk <- x$foreignKeys[[i]]
        if (
          fk$cardinality["fmin"] > 0 &&
            nrow(fk$key) == 1 &&
            fk$refTable %in% names(toRet)
        ) {
          toRet[[fk$refTable]]$fields[
            which(toRet[[fk$refTable]]$fields$name == fk$key$from),
            "nullable"
          ] <- FALSE
        }
        if (fk$cardinality["tmin"] > 0 && nrow(fk$key) == 1) {
          toRet[[ft]]$fields[
            which(toRet[[ft]]$fields$name == fk$key$from),
            "nullable"
          ] <- FALSE
        }

        if (fk$cardinality["fmax"] == 1) {
          if (nrow(fk$key) == 1) {
            if (
              toRet[[ft]]$fields[
                which(toRet[[ft]]$fields$name == fk$key$from),
                "type"
              ] %in%
                c("row", "column")
            ) {
              stop("Matrix row and column cannot be unique individually")
            }
            toRet[[ft]]$fields[
              which(toRet[[ft]]$fields$name == fk$key$from),
              "unique"
            ] <- TRUE
          }

          ei <- lapply(
            toRet[[ft]]$indexes,
            function(y) {
              identical(sort(y$fields), sort(fk$key$from))
            }
          ) |>
            unlist() |>
            as.logical() |>
            which()
          if (length(ei) > 1) {
            stop("Check this part of code")
          }
          if (length(ei) == 0) {
            if (createFKIndex) {
              toRet[[ft]]$indexes <- unique(c(
                toRet[[ft]]$indexes,
                list(
                  list(
                    fields = sort(fk$key$from),
                    unique = TRUE
                  )
                )
              ))
            }
          } else {
            toRet[[ft]]$indexes[[ei]]$unique <- TRUE
          }
        }

        if (fk$cardinality["tmax"] == 1 && fk$refTable %in% names(toRet)) {
          if (nrow(fk$key) == 1) {
            if (
              toRet[[fk$refTable]]$fields[
                which(toRet[[fk$refTable]]$fields$name == fk$key$to),
                "type"
              ] %in%
                c("row", "column")
            ) {
              stop("Matrix row and column cannot be unique individually")
            }
            toRet[[fk$refTable]]$fields[
              which(toRet[[fk$refTable]]$fields$name == fk$key$to),
              "unique"
            ] <- TRUE
          }

          ei <- lapply(
            toRet[[fk$refTable]]$indexes,
            function(y) {
              identical(sort(y$fields), sort(fk$key$to))
            }
          ) |>
            unlist() |>
            as.logical() |>
            which()
          if (length(ei) > 1) {
            stop("Check this part of code")
          }
          if (length(ei) == 0) {
            if (createFKIndex) {
              toRet[[fk$refTable]]$indexes <- unique(c(
                toRet[[fk$refTable]]$indexes,
                list(
                  list(
                    fields = sort(fk$key$to),
                    unique = TRUE
                  )
                )
              ))
            }
          } else {
            toRet[[fk$refTable]]$indexes[[ei]]$unique <- TRUE
          }
        }
      }
    }
  }
  toRet <- lapply(toRet, correct_constraints)

  ## Return the results ----
  class(toRet) <- c("RelDataModel", class(toRet))
  if (checkFK) {
    check_foreign_keys(toRet)
  }
  return(toRet)
}

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

###############################################################################@
#' Check the availability of foreign keys
#'
#' @param x a [RelDataModel] object
#'
#' @return Nothing. The function throws an error if there is an issue with
#' foreign keys.
#'
#' @export
#'
check_foreign_keys <- function(x) {
  stopifnot(is.RelDataModel(x))
  lapply(
    x,
    function(tm) {
      fks <- tm$foreignKeys
      if (is.null(fks)) {
        return()
      }
      lapply(
        fks,
        function(fk) {
          ft <- which(unlist(lapply(
            x,
            function(y) {
              y$tableName == fk$refTable
            }
          )))
          if (length(ft) != 1) {
            stop(sprintf(
              "Cannot find the foreign table: %s",
              fk$refTable
            ))
          }
          ft <- x[[ft]]
          for (i in 1:nrow(fk$key)) {
            from <- fk$key[i, ]$from
            to <- fk$key[i, ]$to
            if (!to %in% ft$fields$name) {
              stop(sprintf(
                "Cannot find the %s field in the %s table",
                to,
                fk$refTable
              ))
            }
            fromt <- tm$fields$type[which(tm$fields$name == from)]
            fromt <- ifelse(
              fromt %in% c("row", "column"),
              "character",
              fromt
            )
            tot <- ft$fields$type[which(ft$fields$name == to)]
            tot <- ifelse(
              tot %in% c("row", "column"),
              "character",
              tot
            )
            if (fromt != tot) {
              stop(sprintf(
                paste(
                  "The %s field in the %s table and",
                  "the %s field in the %s table",
                  "are not of the same type"
                ),
                from,
                tm$tableName,
                to,
                ft$tableName
              ))
            }
          }
        }
      )
    }
  )
  invisible(NULL)
}

###############################################################################@
#' @export
#'
length.RelDataModel <- function(x) {
  length(unclass(x))
}

###############################################################################@
#' Subset a [RelDataModel]
#'
#' @param x the [RelDataModel] objcet
#' @param i the index or the names of the elements to extract
#' @param rmForeignKeys if TRUE, remove foreign keys which are not
#' available after extraction. If FALSE (default) the function will throw an
#' error if any foreign keys does not exist in the extracted RelDataModel.
#' @param ... additional arguments for the \code{\link{RelDataModel}} function.
#'
#' @export
#'
'[.RelDataModel' <- function(x, i, rmForeignKeys = FALSE, ...) {
  l <- unclass(x)
  l <- l[i]
  if (rmForeignKeys) {
    l <- lapply(
      l,
      function(tm) {
        if (length(tm$foreignKeys) > 0) {
          tm$foreignKeys <- tm$foreignKeys[which(unlist(lapply(
            tm$foreignKeys,
            function(fk) {
              fk$refTable %in% names(l)
            }
          )))]
        }
        return(tm)
      }
    )
    return(RelDataModel(l = l, ...))
  } else {
    toRet <- try(RelDataModel(l = l, ...), silent = TRUE)
    if (inherits(toRet, "try-error")) {
      if (length(grep("Cannot find the foreign table", toRet)) > 0) {
        toRet <- paste0(
          toRet,
          "Set rmForeignKeys to TRUE to remove unavailable foreign keys\n"
        )
      }
      stop(toRet)
    } else {
      return(toRet)
    }
  }
}

###############################################################################@
#' @export
#'
'[<-.RelDataModel' <- function(x, i, value) {
  stop("'[<-' is not supported for RelDataModel: use 'c' instead")
}

###############################################################################@
#' @export
#'
'[[<-.RelDataModel' <- function(x, i, value) {
  stop("'[[<-' is not supported for RelDataModel: use 'c' instead")
}

###############################################################################@
#' @export
#'
names.RelDataModel <- function(x) {
  names(unclass(x))
}

###############################################################################@
#' @export
#'
'names<-.RelDataModel' <- function(x, value) {
  stopifnot(
    is.character(value),
    length(value) == length(x),
    sum(duplicated(value)) == 0
  )
  ovalues <- names(x)
  l <- unclass(x)
  for (i in 1:length(l)) {
    l[[i]]$tableName <- value[i]
    fk <- l[[i]]$foreignKeys
    if (length(fk) > 0) {
      for (j in 1:length(fk)) {
        nn <- value[which(
          ovalues == fk[[j]]$refTable
        )]
        fk[[j]]$refTable <- nn
      }
    }
    l[[i]]$foreignKeys <- fk
  }
  return(RelDataModel(l = l))
}


###############################################################################@
#' Merge [RelDataModel] objects
#'
#' @param ... [RelDataModel] objects
#' @param checkFK a logical indicating if foreign keys should be checked
#' (default: TRUE)
#'
#' @return A [RelDataModel] objects
#'
#' @export
#'
c.RelDataModel <- function(..., checkFK = TRUE) {
  inputs <- list(...)
  stopifnot(
    all(unlist(lapply(inputs, is.RelDataModel)))
  )
  il <- lapply(
    inputs,
    function(x) {
      return(unclass(x))
    }
  )
  l <- do.call(c, il)
  return(RelDataModel(
    l = l,
    checkFK = checkFK
  ))
}

###############################################################################@
#' Convert a [RelDataModel] object in a list of 5 normalized tibbles
#'
#' @param rdm a [RelDataModel] object
#'
#' @return A list with the following tibbles:
#'
#' - **tables**: The tables in the model with the following information
#'    + **name**: the name of the table
#'    + **x**: the x coordinate of the table in the model drawing
#'    (NA ==> position undefined)
#'    + **y**: the y coordinate of the table in the model drawing
#'    (NA ==> position undefined)
#'    + **color**: the color of the table in the model drawing
#'    (NA ==> undefined)
#'    + **comment**: comment about the table
#'
#' - **fields**: The fields in the model with the following information
#'    + **name**: the name of the field
#'    + **type**: the type of the field
#'    + **nullable**: a logical indicating if the field can be null
#'    + **comment**: comment about the field
#'    + **table**: the name of the table to which the field belongs
#'
#' - **primaryKeys**: The primary keys in the model with the
#' following information
#'    + **table**: the name of the relevant table
#'    + **field**: the name of the field participating to the primary key
#'
#' - **foreignKeys**: The foreign keys in the model with the
#' following information
#'    + **table**: the name of the referring table
#'    + **fki**: the identifier of the foreign key (by referring table)
#'    + **field**: the name of the referring field
#'    + **refTable**: the name of the referred table
#'    + **refField**: the name of the referred field
#'
#' - **indexes**: The indexes in the model with the following information
#'    + **table**: the name of the relevant table
#'    + **idx**: the identifier of the index (by table)
#'    + **field**: the name of the field participating to the index
#'    + **unique**: a logical indicating if the field is unique
#'
#' @export
toDBM <- function(rdm) {
  stopifnot(is.RelDataModel(rdm))
  toRet <- lapply(
    rdm,
    function(tm) {
      ##
      tables <- dplyr::tibble(
        name = tm$tableName,
        x = as.numeric(NA),
        y = as.numeric(NA),
        color = as.character(NA),
        comment = as.character(NA)
      )
      if (!is.null(tm$display)) {
        for (n in c("x", "y", "color", "comment")) {
          tables[, n] <- tm$display[[n]]
        }
      }
      ##
      fields <- tm$fields |>
        dplyr::mutate(
          table = tm$tableName,
          fieldOrder = 1:nrow(tm$fields)
        )
      ##
      if (length(tm$primaryKey) == 0) {
        primaryKeys <- dplyr::tibble(
          table = character(),
          field = character()
        )
      } else {
        primaryKeys <- dplyr::tibble(
          table = tm$tableName,
          field = tm$primaryKey
        )
      }
      ##
      if (length(tm$foreignKeys) == 0) {
        foreignKeys <- dplyr::tibble(
          table = character(),
          fki = integer(),
          field = character(),
          refTable = character(),
          refField = character()
        )
      } else {
        foreignKeys <- do.call(
          dplyr::bind_rows,
          lapply(
            1:length(tm$foreignKeys),
            function(fki) {
              fmin <- tm$foreignKeys[[fki]]$cardinality["fmin"]
              fmax <- tm$foreignKeys[[fki]]$cardinality["fmax"]
              tmin <- tm$foreignKeys[[fki]]$cardinality["tmin"]
              tmax <- tm$foreignKeys[[fki]]$cardinality["tmax"]
              toRet <- tm$foreignKeys[[fki]]$key |>
                dplyr::mutate(
                  table = tm$tableName,
                  refTable = tm$foreignKeys[[fki]]$refTable,
                  fki = fki,
                  fmin = fmin,
                  fmax = fmax,
                  tmin = tmin,
                  tmax = tmax
                )
              toRet |>
                dplyr::rename("field" = "from", "refField" = "to") |>
                dplyr::select(
                  "table",
                  "fki",
                  "field",
                  "refTable",
                  "refField",
                  "fmin",
                  "fmax",
                  "tmin",
                  "tmax"
                )
            }
          )
        )
      }
      ##
      if (length(tm$indexes) == 0) {
        indexes <- dplyr::tibble(
          table = character(),
          idx = integer(),
          field = character(),
          unique = logical()
        )
      } else {
        indexes <- do.call(
          dplyr::bind_rows,
          lapply(
            1:length(tm$indexes),
            function(idx) {
              if (length(idx) == 0) {
                return(NULL)
              }
              toRet <- dplyr::tibble(
                table = tm$tableName,
                idx = idx,
                unique = tm$indexes[[idx]]$unique,
                field = tm$indexes[[idx]]$fields
              ) |>
                dplyr::select("table", "idx", "field", "unique")
              return(toRet)
            }
          )
        )
      }
      ##
      return(list(
        tables = tables,
        fields = fields,
        primaryKeys = primaryKeys,
        foreignKeys = foreignKeys,
        indexes = indexes
      ))
    }
  )
  return(list(
    tables = do.call(dplyr::bind_rows, lapply(toRet, function(x) x$tables)),
    fields = do.call(dplyr::bind_rows, lapply(toRet, function(x) x$fields)),
    primaryKeys = do.call(
      dplyr::bind_rows,
      lapply(toRet, function(x) x$primaryKeys)
    ),
    foreignKeys = do.call(
      dplyr::bind_rows,
      lapply(toRet, function(x) x$foreignKeys)
    ),
    indexes = do.call(dplyr::bind_rows, lapply(toRet, function(x) x$indexes))
  ))
}

###############################################################################@
#' Convert a list of 5 normalized tibbles in a [RelDataModel] object
#'
#' @param dbm a list with the following tibbles:
#'
#' - **tables**: The tables in the model with the following information
#'    + **name**: the name of the table
#'    + **x**: the x coordinate of the table in the model drawing
#'    (NA ==> position undefined)
#'    + **y**: the y coordinate of the table in the model drawing
#'    (NA ==> position undefined)
#'    + **color**: the color of the table in the model drawing
#'    (NA ==> undefined)
#'    + **comment**: comment about the table
#'
#' - **fields**: The fields in the model with the following information
#'    + **name**: the name of the field
#'    + **type**: the type of the field
#'    + **nullable**: a logical indicating if the field can be null
#'    + **comment**: comment about the field
#'    + **table**: the name of the table to which the field belongs
#'
#' - **primaryKeys**: The primary keys in the model with the
#' following information
#'    + **table**: the name of the relevant table
#'    + **field**: the name of the field participating to the primary key
#'
#' - **foreignKeys**: The foreign keys in the model with the
#' following information
#'    + **table**: the name of the referring table
#'    + **fki**: the identifier of the foreign key (by referring table)
#'    + **field**: the name of the referring field
#'    + **refTable**: the name of the referred table
#'    + **refField**: the name of the referred field
#'
#' - **indexes**: The indexes in the model with the following information
#'    + **table**: the name of the relevant table
#'    + **idx**: the identifier of the index (by table)
#'    + **field**: the name of the field participating to the index
#'    + **unique**: a logical indicating if the field is unique
#'
#' @return A [RelDataModel] object
#'
#' @export
#'
fromDBM <- function(dbm) {
  tableName <- split(dbm$tables$name, dbm$tables$name)

  dbm$fields <- dplyr::arrange(dbm$fields, .data$fieldOrder)
  fields <- split(
    dplyr::select(dbm$fields, -"table", -"fieldOrder"),
    dbm$fields$table
  )

  primaryKey <- split(dbm$primaryKeys$field, dbm$primaryKeys$table)

  foreignKeys <- split(
    dplyr::select(dbm$foreignKeys, -"table"),
    dbm$foreignKeys$table
  ) |>
    lapply(function(tfk) {
      split(dplyr::select(tfk, -"fki"), tfk$fki) |>
        lapply(function(fk) {
          list(
            refTable = fk$refTable[1],
            key = dplyr::select(fk, "from" = "field", "to" = "refField"),
            cardinality = c(
              fk$fmin[1],
              fk$fmax[1],
              fk$tmin[1],
              fk$tmax[1]
            ) |>
              stats::setNames(c("fmin", "fmax", "tmin", "tmax"))
          )
        }) |>
        stats::setNames(NULL)
    })

  indexes <- split(dplyr::select(dbm$indexes, -"table"), dbm$indexes$table) |>
    lapply(function(ti) {
      split(dplyr::select(ti, -"idx"), ti$idx) |>
        lapply(function(idx) {
          return(list(fields = idx$field, unique = idx$unique[1]))
        }) |>
        stats::setNames(NULL)
    })

  display <- split(dplyr::select(dbm$tables, -"name"), dbm$tables$name) |>
    lapply(function(di) {
      di |>
        (function(x) {
          class(x) <- "list"
          x
        })() |>
        `attr<-`("row.names", NULL)
    })

  toRet <- lapply(
    tableName,
    function(tn) {
      return(RelTableModel(
        tableName = tn,
        fields = fields[[tn]],
        primaryKey = primaryKey[[tn]],
        foreignKeys = foreignKeys[[tn]],
        indexes = indexes[[tn]],
        display = display[[tn]]
      ))
    }
  ) |>
    RelDataModel()

  return(toRet)
}

###############################################################################@
#' Rename a table in a [RelDataModel]
#'
#' @param x a [RelDataModel] object
#' @param old a single character corresponding to the table name to change
#' @param new the new table name
#'
#' @return A [RelDataModel]
#'
#' @export
#'
rename_table <- function(x, old, new) {
  stopifnot(is.RelDataModel(x))
  stopifnot(
    is.RelDataModel(x),
    length(old) == 1,
    length(new) == 1,
    old %in% names(x)
  )
  newNames <- names(x)
  newNames[which(newNames == old)] <- new
  names(x) <- newNames
  return(x)
}

###############################################################################@
#' Add a table to a [RelDataModel]
#'
#' @param x a [RelDataModel]
#' @param newTable the name of the new table or a [RelTableModel]
#'
#' @return A [RelDataModel]
#'
#' @export
#'
#'
add_table <- function(x, newTable) {
  stopifnot(is.RelDataModel(x))
  stopifnot(is.RelTableModel(newTable) || is.character(newTable))
  if (is.character(newTable)) {
    stopifnot(
      length(newTable) == 1
    )
    newTable <- RelTableModel(
      tableName = newTable,
      fields = dplyr::tibble(
        name = character(),
        type = character(),
        nullable = logical(),
        unique = logical(),
        comment = character()
      ),
      primaryKey = NULL,
      foreignKeys = NULL,
      indexes = NULL,
      display = list(
        x = as.numeric(NA),
        y = as.numeric(NA),
        color = as.character(NA),
        comment = as.character(NA)
      )
    )
  }
  stopifnot(!newTable$tableName %in% names(x))
  x <- unclass(x)
  x[[newTable$tableName]] <- newTable
  return(RelDataModel(x))
}

###############################################################################@
#' Remove a table from a [RelDataModel]
#'
#' @param x a [RelDataModel]
#' @param tableName the name of the table to remove
#' @param rmForeignKeys if TRUE, remove foreign keys which are not
#' available after extraction. If FALSE (default) the function will throw an
#' error if any foreign keys does not exist in the extracted RelDataModel.
#'
#' @return A [RelDataModel]
#'
#' @export
#'
remove_table <- function(x, tableName, rmForeignKeys = FALSE) {
  stopifnot(is.RelDataModel(x))
  stopifnot(
    is.character(tableName),
    length(tableName) == 1,
    tableName %in% names(x)
  )
  return(x[-which(names(x) == tableName), rmForeignKeys = rmForeignKeys])
}

###############################################################################@
#' Add a field to a table in a [RelDataModel]
#'
#' @param x a [RelDataModel]
#' @param tableName the name of the table to modify (a single character)
#' @param name the name of the field to add (a single character)
#' @param type the type of the field (a single character)
#' @param nullable if the field is nullable (a single logical)
#' @param unique if the values are unique (a single logical)
#' @param comment a description (a single character)
#'
#' @return A [RelDataModel]
#'
#' @export
#'
add_field <- function(
  x,
  tableName,
  name,
  type,
  nullable,
  unique,
  comment
) {
  stopifnot(is.RelDataModel(x))
  stopifnot(
    is.character(tableName),
    length(tableName) == 1,
    !is.MatrixModel(x[[tableName]]),
    !is.na(tableName),
    tableName %in% names(x),
    is.character(name),
    length(name) == 1,
    !is.na(name),
    !name %in% x[[tableName]]$fields$name,
    is.character(type),
    length(type) == 1,
    !is.na(type),
    type %in% c(SUPPTYPES, "row", "column"),
    is.logical(nullable),
    length(nullable) == 1,
    !is.na(nullable),
    is.logical(unique),
    length(unique) == 1,
    !is.na(unique),
    is.character(comment),
    length(comment) == 1
  )
  x <- unclass(x)
  if (type %in% c("row", "column")) {
    stopifnot(
      length(x[[tableName]]) == 0 #, !nullable, unique
    )
    x[[tableName]]$fields <- dplyr::tibble(
      name = c(
        name,
        paste0(
          toupper(setdiff(c("row", "column"), type)),
          "_TO_UPDATE"
        ),
        "VALUE_TO_UPDATE"
      ),
      type = c(type, setdiff(c("row", "column"), type), "character"),
      nullable = c(FALSE, FALSE, TRUE),
      unique = c(FALSE, FALSE, FALSE),
      comment = c(comment, NA, NA)
    )
    x[[tableName]]$primaryKey <- x[[tableName]]$fields$name[1:2]
  } else {
    x[[tableName]]$fields <- dplyr::bind_rows(
      x[[tableName]]$fields,
      dplyr::tibble(
        name = name,
        type = type,
        nullable = nullable,
        unique = unique,
        comment = comment
      )
    )
  }
  return(RelDataModel(x))
}

###############################################################################@
#' Rename an existing field in a [RelDataModel] table
#'
#' @param x a [RelDataModel]
#' @param tableName the name of the table to modify (a single character)
#' @param current the current name of the field to modify (a single character)
#' @param new the new name of the field (a single character)
#'
#' @return A [RelDataModel]
#'
#' @export
#'
rename_field <- function(x, tableName, current, new) {
  stopifnot(is.RelDataModel(x))
  stopifnot(
    is.character(tableName),
    length(tableName) == 1,
    tableName %in% names(x),
    is.character(current),
    length(current) == 1,
    current %in% x[[tableName]]$fields$name,
    current != new,
    is.character(new),
    length(new) == 1,
    !new %in% x[[tableName]]$fields$name
  )
  x <- unclass(x)
  tm <- x[[tableName]]
  ## Renaming the field ----
  tm$fields[
    which(tm$fields$name == current),
    "name"
  ] <- new
  ## Adapting primary key ----
  tm$primaryKey[which(tm$primaryKey == current)] <- new
  tm$primaryKey <- sort(tm$primaryKey)
  ## Adapting indexes ----
  if (length(tm$indexes) > 0) {
    for (i in 1:length(tm$indexes)) {
      tm$indexes[[i]]$fields[
        which(tm$indexes[[i]]$fields == current)
      ] <- new
      tm$indexes[[i]]$fields <- sort(tm$indexes[[i]]$fields)
    }
  }
  ## Adapting foreign keys ----
  if (length(tm$foreignKeys) > 0) {
    for (i in 1:length(tm$foreignKeys)) {
      tm$foreignKeys[[i]]$key[
        which(tm$foreignKeys[[i]]$key$from == current),
        "from"
      ] <- new
    }
  }
  x[[tableName]] <- tm
  ## Changing foreign Keys in other tables ----
  for (i in 1:length(x)) {
    tm <- x[[i]]
    keys <- tm$foreignKeys
    if (length(keys) > 0) {
      for (j in 1:length(keys)) {
        if (keys[[j]]$refTable == tableName) {
          keys[[j]]$key[which(keys[[j]]$key$to == current), "to"] <- new
        }
      }
    }
    tm$foreignKeys <- keys
    x[[i]] <- tm
  }
  return(RelDataModel(x))
}

###############################################################################@
fk_match <- function(
  x,
  fromTable,
  fromFields,
  toTable,
  toFields
) {
  tocheck <- paste(fromFields, toFields, sep = "-->") |> sort()
  tfk <- x[[fromTable]]$foreignKeys
  lapply(
    tfk,
    function(y) {
      y$refTable == toTable &&
        nrow(y$key) == length(tocheck) &&
        all(
          sort(paste(y$key$from, y$key$to, sep = "-->")) == tocheck
        )
    }
  ) |>
    unlist() |>
    as.logical() |>
    which()
}

###############################################################################@
#' Add a foreign key between two tables
#'
#' @param x a [RelDataModel]
#' @param fromTable the name of the referencing table
#' @param fromFields the name of the referencing fields
#' @param toTable the name of the referenced table
#' @param toFields the names of the referenced fields
#' @param fmin from minimum cardinality (default: 0L)
#' @param fmax from maximum cardinality (default: -1L ==> Infinite)
#' @param tmin to minimum cardinality (default: 1L)
#' @param tmax to maximum cardinality (default: 1L)
#'
#' @return A [RelDataModel]
#'
#' @export
#'
add_foreign_key <- function(
  x,
  fromTable,
  fromFields,
  toTable,
  toFields,
  fmin = 0L,
  fmax = -1L,
  tmin = 1L,
  tmax = 1L
) {
  stopifnot(is.RelDataModel(x))
  ft <- x[[fromTable]]$fields$type[
    match(fromFields, x[[fromTable]]$fields$name)
  ]
  ft <- ifelse(ft %in% c("row", "column"), "character", ft)
  tt <- x[[toTable]]$fields$type[
    match(toFields, x[[toTable]]$fields$name)
  ]
  tt <- ifelse(tt %in% c("row", "column"), "character", tt)
  stopifnot(
    is.character(fromTable),
    length(fromTable) == 1,
    fromTable %in% names(x),
    is.character(toTable),
    length(toTable) == 1,
    toTable %in% names(x),
    is.character(fromFields),
    length(fromFields) >= 1,
    is.character(toFields),
    length(toFields) == length(fromFields),
    all(fromFields %in% x[[fromTable]]$fields$name),
    all(toFields %in% x[[toTable]]$fields$name),
    all(ft == tt),
    all(ft != "base64"),
    all(!is.na(c(fmin, fmax, tmin, tmax))),
    is.integer(fmin),
    is.integer(fmax),
    is.integer(tmin),
    is.integer(tmax),
    fmin > -1,
    tmin > -1,
    fmax == -1 || (fmax > 0 && fmax >= fmin),
    tmax == -1 || (tmax > 0 && tmax >= tmin)
  )
  if (is.MatrixModel(x[[fromTable]])) {
    fi <- x[[fromTable]]$fields |> dplyr::filter(.data$name %in% fromFields)
    if (any(!fi$type %in% c("row", "column"))) {
      stop(paste(
        "Only row and column of matrices can be used in foreign keys"
      ))
    }
    if (fmax == 1 && nrow(fi) == 1) {
      stop("Matix row and column cannot be mapped individually unambiguisly")
    }
  }
  if (is.MatrixModel(x[[toTable]])) {
    fi <- x[[toTable]]$fields |> dplyr::filter(.data$name %in% toFields)
    if (any(!fi$type %in% c("row", "column"))) {
      stop(paste(
        "Only row and column of matrices can be used in foreign keys"
      ))
    }
    if (tmax == 1 && nrow(fi) == 1) {
      stop("Matix row and column cannot be mapped individually unambiguisly")
    }
  }
  efk <- fk_match(x, fromTable, fromFields, toTable, toFields)
  if (length(efk) != 0) {
    warning("The foreign key already exists ==> no change")
    return(x)
  }
  x <- unclass(x)
  x[[fromTable]]$foreignKeys <- c(
    x[[fromTable]]$foreignKeys,
    list(list(
      refTable = toTable,
      key = dplyr::tibble(
        from = fromFields,
        to = toFields
      ),
      cardinality = c(
        "fmin" = as.integer(fmin),
        "fmax" = as.integer(fmax),
        "tmin" = as.integer(tmin),
        "tmax" = as.integer(tmax)
      )
    ))
  )
  return(RelDataModel(x))
}

###############################################################################@
#' Remove a foreign key between two tables
#'
#' @param x a [RelDataModel]
#' @param fromTable the name of the referencing table
#' @param fromFields the name of the referencing fields
#' @param toTable the name of the referenced table
#' @param toFields the names of the referenced fields
#'
#' @return A [RelDataModel]
#'
#' @export
#'
remove_foreign_key <- function(
  x,
  fromTable,
  fromFields,
  toTable,
  toFields
) {
  stopifnot(is.RelDataModel(x))
  stopifnot(
    is.character(fromTable),
    length(fromTable) == 1,
    fromTable %in% names(x),
    is.character(toTable),
    length(toTable) == 1,
    toTable %in% names(x),
    is.character(fromFields),
    length(fromFields) >= 1,
    is.character(toFields),
    length(toFields) == length(fromFields),
    all(fromFields %in% x[[fromTable]]$fields$name),
    all(toFields %in% x[[toTable]]$fields$name)
  )
  efk <- fk_match(x, fromTable, fromFields, toTable, toFields)
  if (length(efk) == 0) {
    warning("The foreign key does not exist ==> no change")
    return(x)
  }
  x <- unclass(x)
  x[[fromTable]]$foreignKeys <- x[[fromTable]]$foreignKeys[-efk]
  return(RelDataModel(x))
}

###############################################################################@
#' Update a the cardinalities of a foreign key between two tables
#'
#' @param x a [RelDataModel]
#' @param fromTable the name of the referencing table
#' @param fromFields the name of the referencing fields
#' @param toTable the name of the referenced table
#' @param toFields the names of the referenced fields
#' @param fmin from minimum cardinality
#' @param fmax from maximum cardinality
#' @param tmin to minimum cardinality
#' @param tmax to maximum cardinality
#'
#' @return A [RelDataModel]
#'
#' @export
#'
update_foreign_key <- function(
  x,
  fromTable,
  fromFields,
  toTable,
  toFields,
  fmin,
  fmax,
  tmin,
  tmax
) {
  stopifnot(is.RelDataModel(x))
  toRet <- x |>
    remove_foreign_key(
      fromTable,
      fromFields,
      toTable,
      toFields
    ) |>
    add_foreign_key(
      fromTable,
      fromFields,
      toTable,
      toFields,
      fmin,
      fmax,
      tmin,
      tmax
    )
  return(toRet)
}

###############################################################################@
#' Remove a field from a table in a [RelDataModel]
#'
#' @param x a [RelDataModel]
#' @param tableName the name of the table to modify (a single character)
#' @param fieldName the name of the field to remove (a single character)
#' @param rmForeignKeys a single logical indicating if the corresponding foreign
#' keys should be removed. If FALSE (default), the function will throw an
#' error if it encounter a foreign key using the field.
#'
#' @return A [RelDataModel]
#'
#' @export
#'
remove_field <- function(
  x,
  tableName,
  fieldName,
  rmForeignKeys = FALSE
) {
  stopifnot(is.RelDataModel(x))
  stopifnot(
    is.character(tableName),
    length(tableName) == 1,
    !is.MatrixModel(x[[tableName]]),
    tableName %in% names(x),
    is.character(fieldName),
    length(fieldName) == 1,
    fieldName %in% x[[tableName]]$fields$name
  )
  ## Foreign keys ----
  refk <- lapply(
    x[[tableName]]$foreignKeys,
    function(y) {
      fieldName %in% y$key$from
    }
  ) |>
    unlist() |>
    as.logical() |>
    which()
  tefk <- lapply(
    x,
    function(y) {
      lapply(
        y$foreignKeys,
        function(z) {
          tableName == z$refTable &
            fieldName %in% z$key$to
        }
      ) |>
        unlist() |>
        as.logical() |>
        which()
    }
  )
  x <- unclass(x)
  if (length(refk) > 0 || any(unlist(lapply(tefk, length)) > 0)) {
    if (!rmForeignKeys) {
      stop(
        "This field is used as a foreign key.\n",
        "Set rmForeignKeys to TRUE to remove them"
      )
    } else {
      if (length(refk) > 0) {
        x[[tableName]]$foreignKeys <- x[[tableName]]$foreignKeys[-refk]
      }
      for (tn in names(tefk)) {
        if (length(tefk[[tn]] > 0)) {
          x[[tn]]$foreignKeys <- x[[tn]]$foreignKeys[-tefk[[tn]]]
        }
      }
    }
  }
  ## Adapting primary key ----
  if (fieldName %in% x[[tableName]]$primaryKey) {
    x[[tableName]]$primaryKey <- character()
  }
  ## Adapting indexes ----
  if (length(x[[tableName]]$indexes) > 0) {
    toRm <- c()
    for (i in 1:length(x[[tableName]]$indexes)) {
      if (fieldName %in% x[[tableName]]$indexes[[i]]$fields) {
        toRm <- c(toRm, i)
      }
    }
    if (length(toRm) > 0) {
      x[[tableName]]$indexes <- x[[tableName]]$indexes[-toRm]
    }
  }
  ## Removing the field ----
  x[[tableName]]$fields <- x[[tableName]]$fields |>
    dplyr::filter(.data$name != fieldName)
  ## Returning the results ----
  return(RelDataModel(x))
}

###############################################################################@
#' Order fields in a table in a [RelDataModel]
#'
#' @param x a [RelDataModel]
#' @param tableName the name of the table to modify (a single character)
#' @param order a vector of integers all in (1:number_of_fields)
#'
#' @return A [RelDataModel]
#'
#' @export
#'
order_fields <- function(
  x,
  tableName,
  order
) {
  stopifnot(is.RelDataModel(x))
  stopifnot(
    is.character(tableName),
    length(tableName) == 1,
    tableName %in% names(x),
    is.numeric(order),
    length(order) == nrow(x[[tableName]]$fields),
    all(order %in% 1:nrow(x[[tableName]]$fields))
  )
  x <- unclass(x)
  x[[tableName]]$fields <- x[[tableName]]$fields[order, ]
  return(RelDataModel(x))
}

###############################################################################@
#' Set the primary key a table in a [RelDataModel]
#'
#' @param x a [RelDataModel]
#' @param tableName the name of the table to modify (a single character)
#' @param fieldNames the names of the fields to include in the primary key
#'
#' @return A [RelDataModel]
#'
#' @export
#'
set_primary_key <- function(x, tableName, fieldNames) {
  stopifnot(is.RelDataModel(x))
  fieldNames <- as.character(fieldNames)
  stopifnot(
    is.character(tableName),
    length(tableName) == 1,
    !is.MatrixModel(x[[tableName]]),
    tableName %in% names(x),
    all(fieldNames %in% x[[tableName]]$fields$name)
  )
  x <- unclass(x)
  x[[tableName]]$primaryKey <- sort(fieldNames)
  return(RelDataModel(x))
}


###############################################################################@
#' Add an index to a table in a [RelDataModel]
#'
#' @param x a [RelDataModel]
#' @param tableName the name of the table to modify (a single character)
#' @param fieldNames the names of the fields to include in the index
#' @param unique a logical indicating if the indexed values are unique
#'
#' @return A [RelDataModel]
#'
#' @export
#'
add_index <- function(x, tableName, fieldNames, unique) {
  stopifnot(is.RelDataModel(x))
  fieldNames <- as.character(fieldNames) |> unique()
  stopifnot(
    is.character(tableName),
    length(tableName) == 1,
    tableName %in% names(x),
    all(fieldNames %in% x[[tableName]]$fields$name),
    is.logical(unique),
    length(unique) == 1
  )
  ei <- lapply(
    x[[tableName]]$indexes,
    function(y) {
      identical(sort(y$fields), sort(fieldNames))
    }
  ) |>
    unlist() |>
    as.logical() |>
    any()
  if (ei) {
    warning("An index with the same fields already exists ==> no change")
    return(x)
  }
  x <- unclass(x)
  x[[tableName]]$indexes <- c(
    x[[tableName]]$indexes,
    list(list(fields = fieldNames, unique = unique))
  )
  return(RelDataModel(x))
}

###############################################################################@
#' Remove an index from a table in a [RelDataModel]
#'
#' @param x a [RelDataModel]
#' @param tableName the name of the table to modify (a single character)
#' @param fieldNames the names of the fields composing the index
#'
#' @return A [RelDataModel]
#'
#' @export
#'
remove_index <- function(x, tableName, fieldNames) {
  stopifnot(is.RelDataModel(x))
  fieldNames <- as.character(fieldNames)
  stopifnot(
    is.character(tableName),
    length(tableName) == 1,
    tableName %in% names(x),
    all(fieldNames %in% x[[tableName]]$fields$name)
  )
  ei <- lapply(
    x[[tableName]]$indexes,
    function(y) {
      identical(sort(y$fields), sort(fieldNames))
    }
  ) |>
    unlist() |>
    as.logical() |>
    which()
  if (length(ei) == 0) {
    warning("The index does not exists ==> no change")
    return(x)
  }
  x <- unclass(x)
  x[[tableName]]$indexes <- x[[tableName]]$indexes[-ei]
  return(RelDataModel(x))
}

##############################################################################@
#' Order index in a table in a [RelDataModel]
#'
#' @param x a [RelDataModel]
#' @param tableName the name of the table to modify (a single character)
#' @param order a vector of integers all in (1:number_of_indexes)
#'
#' @return A [RelDataModel]
#'
#' @export
#'
order_indexes <- function(
  x,
  tableName,
  order
) {
  stopifnot(is.RelDataModel(x))
  stopifnot(
    is.character(tableName),
    length(tableName) == 1,
    tableName %in% names(x),
    is.numeric(order),
    length(order) == length(x[[tableName]]$indexes),
    all(order %in% 1:length(x[[tableName]]$indexes))
  )
  x <- unclass(x)
  x[[tableName]]$indexes <- x[[tableName]]$indexes[order]
  return(RelDataModel(x))
}

###############################################################################@
#' Set table index uniqueness in a [RelDataModel]
#'
#' @param x a [RelDataModel]
#' @param tableName the name of the table to modify (a single character)
#' @param fieldNames the names of the fields composing the index
#' @param unique a logical value
#'
#' @return A [RelDataModel]
#'
#' @export
#'
set_unique_index <- function(x, tableName, fieldNames, unique) {
  stopifnot(is.RelDataModel(x))
  fieldNames <- as.character(fieldNames)
  stopifnot(
    is.character(tableName),
    length(tableName) == 1,
    tableName %in% names(x),
    all(fieldNames %in% x[[tableName]]$fields$name),
    is.logical(unique),
    length(unique) == 1,
    !is.na(unique)
  )
  ei <- lapply(
    x[[tableName]]$indexes,
    function(y) {
      identical(sort(y$fields), sort(fieldNames))
    }
  ) |>
    unlist() |>
    as.logical() |>
    which()
  if (length(ei) == 0) {
    warning("The index does not exists ==> no change")
    return(x)
  }
  x <- unclass(x)
  x[[tableName]]$indexes[[ei]]$unique <- unique
  return(RelDataModel(x))
}

###############################################################################@
#' Update field information in a table of a [RelDataModel]
#'
#' @param x a [RelDataModel]
#' @param tableName the name of the table to modify (a single character)
#' @param fieldName the name of the field to modify (a single character)
#' @param type the type of the field (a single character)
#' @param nullable if the field is nullable (a single logical)
#' @param unique if the values are unique (a single logical)
#' @param comment a description (a single character)
#'
#' @return A [RelDataModel]
#'
#' @export
#'
update_field <- function(
  x,
  tableName,
  fieldName,
  type = NULL,
  nullable = NULL,
  unique = NULL,
  comment = NULL
) {
  stopifnot(is.RelDataModel(x))
  stopifnot(
    is.character(tableName),
    length(tableName) == 1,
    tableName %in% names(x),
    is.character(fieldName),
    length(fieldName) == 1,
    fieldName %in% x[[tableName]]$fields$name
  )
  curType <- x[[tableName]]$fields |>
    dplyr::filter(.data$name == fieldName) |>
    dplyr::pull("type")
  type <- ifelse(
    is.null(type),
    curType,
    type
  )
  nullable <- ifelse(
    is.null(nullable),
    x[[tableName]]$fields |>
      dplyr::filter(.data$name == fieldName) |>
      dplyr::pull("nullable"),
    nullable
  )
  unique <- ifelse(
    is.null(unique),
    x[[tableName]]$fields |>
      dplyr::filter(.data$name == fieldName) |>
      dplyr::pull("unique"),
    unique
  )
  comment <- ifelse(
    is.null(comment),
    x[[tableName]]$fields |>
      dplyr::filter(.data$name == fieldName) |>
      dplyr::pull("comment"),
    comment
  )
  type <- as.character(type)
  nullable <- as.logical(nullable)
  unique <- as.logical(unique)
  comment <- as.character(comment)
  stopifnot(
    is.character(type),
    length(type) == 1,
    !is.na(type),
    is.logical(nullable),
    length(nullable) == 1,
    !is.na(nullable),
    is.logical(unique),
    length(unique) == 1,
    !is.na(unique),
    is.character(comment),
    length(comment) == 1
  )

  x <- unclass(x)
  if (is.MatrixModel(x[[tableName]]) && curType %in% c("row", "column")) {
    ## row/column type ----
    if (!type %in% c("row", "column")) {
      stop("row and column can only be mutated in row and column")
    }
    if (nullable || unique) {
      stop("row and column cannot be nullable nor unique")
    }
    ## Updating field information ----
    d2CurType <- setdiff(c("row", "column"), curType)
    d2Type <- setdiff(c("row", "column"), type)
    d2fn <- x[[tableName]]$fields |>
      dplyr::filter(.data$type == !!d2CurType) |>
      dplyr::pull("name")
    x[[tableName]]$fields <- x[[tableName]]$fields |>
      dplyr::mutate(
        type = ifelse(
          .data$name == fieldName,
          !!type,
          ifelse(.data$name == d2fn, !!d2Type, .data$type)
        ),
        comment = ifelse(.data$name == fieldName, !!comment, .data$comment)
      )
  } else {
    ## Other type ----
    if (type %in% c("row", "column")) {
      stop("Cannot set this field as row or column")
    }
    if (is.MatrixModel(x[[tableName]]) && type == "base64") {
      stop("A matrix cannot store base64 documents")
    }
    check_types(type)
    ## Foreign keys ----
    if (type != curType) {
      refk <- lapply(
        x[[tableName]]$foreignKeys,
        function(y) {
          fieldName %in% y$key$from
        }
      ) |>
        unlist() |>
        as.logical() |>
        which()
      tefk <- lapply(
        x,
        function(y) {
          lapply(
            y$foreignKeys,
            function(z) {
              tableName == z$refTable &
                fieldName %in% z$key$to
            }
          ) |>
            unlist() |>
            as.logical() |>
            which()
        }
      )
      if (length(refk) > 0 || any(unlist(lapply(tefk, length)) > 0)) {
        stop(
          "Cannot change the type of a field involved in a foreign key.\n",
          "You should first remove the foreign key involving it."
        )
      }
    }
    ## Updating field information ----
    x[[tableName]]$fields <- x[[tableName]]$fields |>
      dplyr::mutate(
        type = ifelse(.data$name == fieldName, !!type, .data$type),
        nullable = ifelse(.data$name == fieldName, !!nullable, .data$nullable),
        unique = ifelse(.data$name == fieldName, !!unique, .data$unique),
        comment = ifelse(.data$name == fieldName, !!comment, .data$comment)
      )
  }

  return(RelDataModel(x))
}


###############################################################################@
#' Update the display of a table of a [RelDataModel]
#'
#' @param x a [RelDataModel]
#' @param tableName the name of the table to modify (a single character)
#' @param px the position of the table: x value
#' @param py the position of the table: y value
#' @param color the color of the table
#' @param comment a table description/comment
#'
#' @return A [RelDataModel]
#'
#' @export
#'
update_table_display <- function(
  x,
  tableName,
  px = NULL,
  py = NULL,
  color = NULL,
  comment = NULL
) {
  stopifnot(is.RelDataModel(x))
  px <- ifelse(
    is.null(px),
    x[[tableName]]$display$x,
    px
  )
  py <- ifelse(
    is.null(py),
    x[[tableName]]$display$y,
    py
  )
  color <- ifelse(
    is.null(color),
    x[[tableName]]$display$color,
    color
  )
  comment <- ifelse(
    is.null(comment),
    x[[tableName]]$display$comment,
    comment
  )
  px <- as.numeric(px)
  py <- as.numeric(py)
  color <- as.character(color)
  comment <- as.character(comment)
  stopifnot(
    is.character(tableName),
    length(tableName) == 1,
    tableName %in% names(x),
    is.numeric(px),
    length(px) == 1,
    is.numeric(py),
    length(py) == 1,
    is.character(color),
    length(color) == 1,
    is.character(comment),
    length(comment) == 1
  )
  ## Updating table display ----
  x <- unclass(x)
  x[[tableName]]$display$x <- px
  x[[tableName]]$display$y <- py
  x[[tableName]]$display$color <- color
  x[[tableName]]$display$comment <- comment
  return(RelDataModel(x))
}

###############################################################################@
#' Copy fields from one table to another in a [RelDataModel]
#'
#' @param x a [RelDataModel]
#' @param from the name of the table from which the fields are taken
#' @param to the name of the table to which the fields are copied
#' @param fields the names of the fields to copy
#'
#' @return A [RelDataModel]
#'
#' @export
#'
copy_fields <- function(x, from, to, fields) {
  stopifnot(
    is.RelDataModel(x),
    is.character(from) &&
      length(from) == 1 &&
      !is.na(from) &&
      from %in% names(x),
    is.character(to) && length(to) == 1 && !is.na(to) && to %in% names(x),
    is.character(fields) &&
      length(fields) > 0 &&
      !any(is.na(fields)) &&
      all(fields %in% x[[from]]$fields$name) &&
      !any(fields %in% x[[to]]$fields$name)
  )
  for (f in fields) {
    ff <- dplyr::filter(x[[from]]$fields, .data$name == f)
    x <- add_field(
      x,
      tableName = to,
      name = f,
      type = ff$type,
      nullable = ff$nullable,
      unique = ff$unique,
      comment = ff$comment
    )
  }
  return(x)
}

###############################################################################@
#' Pre-compute [RelDataModel] layout when missing any x or y table position
#'
#' @param x a [RelDataModel]
#' @param layout character name of igraph layout function to use
#' (Default: "layout_nicely").
#' @param lengthMultiplier a numeric value to scale x and y coordinate
#' (default: 40*length(x))
#' @param force if TRUE autolayout even if all tables have coordinates
#' (default: FALSE)
#'
#' @return A [RelDataModel]
#'
#' @export
#'
auto_layout <- function(
  x,
  layout = "layout_nicely",
  lengthMultiplier = 40 * length(x),
  force = FALSE
) {
  stopifnot(is.RelDataModel(x))
  if (length(x) == 0) {
    return(x)
  }
  mn <- modelToVn(x)
  if (force) {
    mn$nodes$x <- NA
    mn$nodes$y <- NA
  }
  if (any(is.na(mn$nodes$x)) || any(is.na(mn$nodes$y))) {
    vp <- mn$nodes |>
      dplyr::select(-"x", -"y") |>
      visNetwork::visNetwork(mn$edges) |>
      visNetwork::visIgraphLayout(layout = layout, randomSeed = 2)
    x <- lapply(
      x,
      function(n) {
        i <- which(vp$x$nodes$id == n$tableName)
        n$display$x <- vp$x$nodes$x[i] * lengthMultiplier
        n$display$y <- vp$x$nodes$y[i] * lengthMultiplier
        return(n)
      }
    )
    class(x) <- c("RelDataModel", "list")
  }
  return(x)
}

###############################################################################@
#' Confront a [RelDataModel] to actual data
#'
#' @param x a [RelDataModel]
#' @param data a list of data frames to be confronted with the model.
#' @param paths a character vector with file paths taken into account if
#' the data is empty.
#' The file [basename] without extension
#' will be considered as the table name.
#' @param returnData a logical indicating if the data should be returned
#' with the report (default: FALSE).
#' @param verbose a single logical value indicating if some process information
#' should be displayed (default: TRUE)
#' @param n_max maximum number of records to read (default: Inf).
#' @param checks a character vector with the name of optional checks to be done
#' (Default: if n_max==Inf ==> all of
#' them c("unique", "not nullable", "foreign keys"),
#' else ==> none)
#' @param delim single character used to separate fields within a record
#' (default: "\\t")
#' @param ... supplementary parameters for the [readr::read_delim] function.
#'
#' @return A report as a list
#'
#' @example inst/examples/ex_read_json.R
#'
#' @export
#'
confront_data <- function(
  x,
  data = list(),
  paths = NULL,
  returnData = FALSE,
  verbose = TRUE,
  n_max = Inf,
  checks = if (n_max == Inf) {
    c("unique", "not nullable", "foreign keys")
  } else {
    as.character()
  },
  delim = "\t",
  ...
) {
  stopifnot(is.RelDataModel(x))

  read_td <- function(tm, tn) {
    if (is.MatrixModel(tm)) {
      ismm <- is_MM(paths[tn])
      if (ismm) {
        td <- read_named_MM(
          paths[tn],
          n_max = n_max
        )
      } else {
        r1 <- attr(ismm, "r1")
        cn <- r1 |>
          strsplit(split = delim) |>
          unlist()
        cn <- gsub("['`]", "", cn)
        cn <- gsub('["]', "", cn)

        vt <- tm$fields |>
          dplyr::filter(!.data$type %in% c("row", "column")) |>
          dplyr::pull("type")
        ctypes <- do.call(
          readr::cols,
          structure(
            list(
              readr::col_character(),
              .default = switch(
                vt,
                "integer" = readr::col_integer(),
                "numeric" = readr::col_double(),
                "logical" = readr::col_logical(),
                "character" = readr::col_character(),
                "Date" = readr::col_date(),
                "POSIXct" = readr::col_datetime()
              )
            ),
            .Names = c("___ROWNAMES___", ".default")
          )
        )
        td <- readr::read_delim(
          paths[tn],
          delim = delim,
          n_max = n_max,
          skip = 1,
          col_types = ctypes,
          col_names = c("___ROWNAMES___", cn[-1]),
          ...
        ) |>
          as.data.frame(stringsAsFactors = FALSE)
        stopifnot(
          !any(duplicated(colnames(td))),
          !any(duplicated(td[[1]]))
        )
        rownames(td) <- td[[1]]
        td <- as.matrix(td[, -1, drop = FALSE])
      }
    } else {
      td <- readr::read_delim(
        paths[tn],
        delim = delim,
        n_max = n_max,
        col_types = col_types(tm),
        ...
      )
    }
    return(td)
  }

  ## Optional checks ----
  if (length(checks) > 0) {
    checks <- match.arg(
      checks,
      c("unique", "not nullable", "foreign keys"),
      several.ok = TRUE
    )
  }

  ## Empty model and data
  if (length(x) == 0 && length(data) == 0 && length(paths) == 0) {
    toRet <- list(
      model = x,
      checks = checks,
      n_max = n_max,
      missingTables = NULL,
      suppTables = NULL,
      availableTables = NULL,
      constraints = list(),
      success = TRUE
    )
    if (verbose) {
      cat(format_confrontation_report(toRet))
    }
    return(invisible(toRet))
  }

  ## Data files ----
  if (length(data) == 0) {
    stopifnot(is.character(paths), length(paths) > 0)
    nf <- paths[which(!file.exists(paths))]
    if (length(nf) > 0) {
      stop(
        "Cannot find the following files:\n   - ",
        paste(nf, collapse = "\n   - ")
      )
    }
    names(paths) <- sub(
      pattern = "(\\.[[:alnum:]]+)(\\.gz)?$",
      replacement = "",
      x = basename(paths)
    )
    dtn <- names(paths)
  } else {
    dtn <- names(data)
    stopifnot(length(dtn) > 0)
  }

  ## Available tables ----
  missingTables <- setdiff(names(x), dtn)
  suppTables <- setdiff(dtn, names(x))
  availableTables <- intersect(names(x), dtn)
  toRet <- list(
    model = x,
    checks = checks,
    n_max = n_max,
    missingTables = missingTables,
    suppTables = suppTables,
    availableTables = availableTables,
    constraints = list(),
    success = length(missingTables) == 0 && length(suppTables) == 0
  )

  ## Table checks ----
  if (length(availableTables) > 0) {
    for (ti in 1:length(availableTables)) {
      tn <- availableTables[ti]
      if (verbose) {
        message(sprintf(
          'Processing "%s" (table %s / %s) ',
          tn,
          ti,
          length(availableTables)
        ))
      }
      tm <- x[[tn]]
      if (tn %in% names(data)) {
        td <- data[[tn]]
      } else {
        td <- read_td(tm, tn)
        if (returnData) {
          data[[tn]] <- td
        }
      }
      ### Simple table ----
      tr <- confront_table_data(x = tm, d = td, checks = checks)
      toRet$success <- toRet$success && tr$success
      ### Foreign keys ----
      tfk <- tm$foreignKeys
      if ("foreign keys" %in% checks && length(tfk) > 0) {
        fkr <- list()
        for (i in 1:length(tfk)) {
          tfki <- tfk[[i]]
          rtn <- tfki$refTable
          if (rtn %in% missingTables) {
            fkr[[i]] <- list(
              "success" = FALSE,
              "message" = "Missing reference table."
            )
            tr$success <- FALSE
            toRet$success <- FALSE
            next()
          }
          ##
          if (tfki$cardinality["fmin"] == 0 && tfki$cardinality["tmin"] == 0) {
            fkr[[i]] <- list("success" = TRUE)
            next()
          }
          ##
          if (rtn == tn) {
            rtd <- td
            rtm <- tm
          } else {
            rtm <- x[[rtn]]
            if (rtn %in% names(data)) {
              rtd <- data[[rtn]]
            } else {
              rtd <- read_td(rtm, rtn)
              if (returnData) {
                data[[rtn]] <- rtd
              }
            }
          }
          ##
          success <- TRUE
          message <- NULL
          if (tfki$cardinality["fmin"] > 0) {
            if (is.MatrixModel(tm) || is.MatrixModel(rtm)) {
              for (j in 1:length(tfki$key$from)) {
                ff <- tfki$key$from[j]
                if (is.MatrixModel(tm)) {
                  fft <- tm$fields$type[which(tm$fields$name == ff)]
                  if (fft == "row") {
                    ffv <- rownames(td)
                  } else {
                    ffv <- colnames(td)
                  }
                } else {
                  ffv <- unique(td[[ff]])
                }
                tf <- tfki$key$to[j]
                if (is.MatrixModel(rtm)) {
                  tft <- rtm$fields$type[which(rtm$fields$name == tf)]
                  if (tft == "row") {
                    tfv <- rownames(rtd)
                  } else {
                    tfv <- colnames(rtd)
                  }
                } else {
                  tfv <- unique(rtd[[tf]])
                }
                fkissue <- !all(tfv %in% ffv)
                if (fkissue) {
                  break()
                }
              }
            } else {
              . <- NULL
              mt <- dplyr::anti_join(
                dplyr::select(rtd, dplyr::all_of(tfki$key$to)) |>
                  dplyr::filter_all(dplyr::any_vars(!is.na(.))),
                dplyr::select(td, dplyr::all_of(tfki$key$from)),
                by = dplyr::all_of(stats::setNames(
                  tfki$key$from,
                  tfki$key$to
                ))
              )
              fkissue <- nrow(mt) > 0
            }
            if (fkissue > 0) {
              success <- FALSE
              message <- paste(
                c(
                  message,
                  sprintf(
                    "All keys of %s should be available in %s.",
                    rtn,
                    tn
                  )
                ),
                collapse = " "
              )
            }
          }
          if (tfki$cardinality["tmin"] > 0) {
            if (is.MatrixModel(tm) || is.MatrixModel(rtm)) {
              for (j in 1:length(tfki$key$from)) {
                ff <- tfki$key$from[j]
                if (is.MatrixModel(tm)) {
                  fft <- tm$fields$type[which(tm$fields$name == ff)]
                  if (fft == "row") {
                    ffv <- rownames(td)
                  } else {
                    ffv <- colnames(td)
                  }
                } else {
                  ffv <- unique(td[[ff]])
                }
                tf <- tfki$key$to[j]
                if (is.MatrixModel(rtm)) {
                  tft <- rtm$fields$type[which(rtm$fields$name == tf)]
                  if (tft == "row") {
                    tfv <- rownames(rtd)
                  } else {
                    tfv <- colnames(rtd)
                  }
                } else {
                  tfv <- unique(rtd[[tf]])
                }
                fkissue <- !all(ffv %in% tfv)
                if (fkissue) {
                  break()
                }
              }
            } else {
              . <- NULL
              mt <- dplyr::anti_join(
                dplyr::select(td, dplyr::all_of(tfki$key$from)) |>
                  dplyr::filter_all(dplyr::any_vars(!is.na(.))),
                dplyr::select(rtd, dplyr::all_of(tfki$key$to)),
                by = dplyr::all_of(stats::setNames(
                  tfki$key$to,
                  tfki$key$from
                ))
              )
              fkissue <- nrow(mt) > 0
            }
            if (fkissue) {
              success <- FALSE
              message <- paste(
                c(
                  message,
                  sprintf(
                    "All keys of %s should be available in %s.",
                    tn,
                    rtn
                  )
                ),
                collapse = " "
              )
            }
          }
          fkr[[i]] <- list(success = success, message = message)
          tr$success <- tr$success && success
          toRet$success <- toRet$success && success
        }
        tr$foreignKey <- fkr
      }
      toRet$constraints[[tn]] <- tr
    }
  }
  if (returnData) {
    toRet$data <- data
  }

  if (verbose) {
    cat(format_confrontation_report(toRet))
  }

  ## Return the results
  invisible(toRet)
}

###############################################################################@
#' Check if two [RelDataModel] are identical
#'
#' @param x a [RelDataModel]
#' @param y a [RelDataModel]
#' @param ... additional parameters for [identical_RelTableModel()]
#'
#' @return A logical: TRUE if the 2 models are identical
#'
#' @export
#'
identical_RelDataModel <- function(x, y, ...) {
  stopifnot(is.RelDataModel(x), is.RelDataModel(y))
  toRet <- length(x) == length(y) && all(sort(names(x)) == sort(names(y)))
  if (toRet && length(x) > 0) {
    for (i in 1:length(x)) {
      itoRet <- identical_RelTableModel(
        x[[names(x)[i]]],
        y[[names(x)[i]]],
        ...
      )
      if (!itoRet) {
        message(sprintf("Tables %s are different", names(x)[i]))
      }
      toRet <- toRet && itoRet
    }
  } else {
    if (length(x) > 0) {
      message("Not the same tables")
    }
  }
  return(toRet)
}


###############################################################################@
#' Get foreign keys in [RelDataModel]
#'
#' @param x a [RelDataModel]
#'
#' @return A tibble with the following fields:
#' - from: the origin of the key
#' - ff: the key fields in from
#' - to: the target of the key
#' - tf: the key fields in to
#' - fmin: minimum cardinality of from
#' - fmax: maximum cardinality of from
#' - tmin: minimum cardinality of to
#' - tmax: maximum cardinality of to
#'
#' @export
#'
get_foreign_keys.RelDataModel <- function(x) {
  do.call(rbind, lapply(x, get_foreign_keys))
}