R/RelTableModel.R

In ReDaMoR: Relational Data Modeler

###############################################################################@
#' Create a RelTableModel object
#'
#' @param l DEPRECATED. A named list with the function parameters.
#' If `NULL` (default) the function parameters are used. If not `NULL`, the
#' function parameters are ignored and taken from l.
#' @param tableName a character vector of length one
#' @param fields a tibble with the following columns:
#'    - *name*: character
#'    - *type*: character
#'    - *nullable*: logical (optional, defaults to TRUE)
#'    - *unique*: logical (optional, defaults = FALSE)
#'    - *comment*:  character (optional, defaults to NA_character_)
#' @param primaryKey a character vector of any length. All
#' values should be in fields$name
#' @param foreignKeys a list of foreign keys. Each foreign key is defined
#' as a list with the following elements:
#'    - *refTable*: a character vector of length one (the referenced table)
#'    - *key*: a tibble with a "from" and a "to" columns
#'    - (*cardinality*): an optional integer vector with 4 values:
#'       + fmin: from minimum cardinality
#'       + fmax: from maximum cardinality
#'       + tmin: to minimum cardinality
#'       + tmax: to maximum cardinality
#' @param indexes a list of indexes. Each index is defined by
#' 3 columns:
#'    - *field*: character (all in fields$name)
#'    - *order*: character
#'    - *unique*: logical
#' @param display a list gathering:
#'    - *x*: single numeric value for the x position of the table
#'    - *y*: single numeric value for the y position of the table
#'    - *color*: single character value corresponding to the color of the table
#'    - *comment*: single character value with some description of the table
#'
#' @details When defining a matrix, 3 and only 3 fields must be defined:
#' 2 of types 'row' and 'column' and the 3rd of your choice. In this case
#' primaryKey is defined automatically as the combination of row and column.
#'
#' @return A RelTableModel object.
#'
#' @export
#'
RelTableModel <- function(
  l = NULL,
  tableName,
  fields,
  primaryKey = NULL,
  foreignKeys = NULL,
  indexes = NULL,
  display = list(
    x = as.numeric(NA),
    y = as.numeric(NA),
    color = as.character(NA),
    comment = as.character(NA)
  )
) {
  ############################################################################@
  ## Management of params ----
  if (!is.null(l)) {
    warning("l param is deprecated and will probably removed in the future")
  } else {
    l <- list(
      tableName = tableName,
      fields = fields,
      primaryKey = primaryKey,
      foreignKeys = foreignKeys,
      indexes = indexes,
      display = display
    )
  }

  ############################################################################@
  ## Checks ----

  ### Simple checks ----
  tableInfo <- c(
    "tableName",
    "fields",
    "primaryKey",
    "foreignKeys",
    "indexes",
    "display"
  )
  mandatoryFieldInfo <- c("name", "type")
  fieldInfo <- c("name", "type", "nullable", "unique", "comment")
  stopifnot(
    is.data.frame(l$fields),
    all(mandatoryFieldInfo %in% colnames(l$fields))
  )
  if (!('nullable' %in% colnames(l$fields))) {
    l$fields$nullable <- TRUE
  }
  if (!('unique' %in% colnames(l$fields))) {
    l$fields$unique <- FALSE
  }
  if (!('comment' %in% colnames(l$fields))) {
    l$fields$comment <- NA_character_
  }
  stopifnot(
    all(tableInfo %in% names(l)),
    all(names(l) %in% tableInfo),

    is.character(l$tableName),
    length(l$tableName) == 1,
    !is.na(l$tableName),

    all(colnames(l$fields) %in% fieldInfo),
    # nrow(l$fields) > 0,
    is.character(l$fields$name),
    all(!is.na(l$fields$name)),
    !any(duplicated(l$fields$name)),
    is.character(l$fields$type),
    all(!is.na(l$fields$type)),
    is.logical(l$fields$nullable),
    all(!is.na(l$fields$nullable)),
    is.logical(l$fields$unique),
    all(!is.na(l$fields$unique)),
    is.character(l$fields$comment),

    is.null(l$primaryKey) || is.character(l$primaryKey),
    all(!is.na(l$primaryKey)),
    all(l$primaryKey %in% l$fields$name)
  )
  for (att in setdiff(
    names(attributes(l$fields)),
    c("row.names", "names", "class")
  )) {
    attr(l$fields, att) <- NULL
  }
  l$fields <- dplyr::as_tibble(l$fields) |>
    dplyr::select(c("name", "type", "nullable", "unique", "comment")) |>
    dplyr::mutate(
      "comment" = as.character(
        ifelse(is.na(.data$comment), "", .data$comment)
      )
    )

  ### Primary key ----
  l$primaryKey <- sort(l$primaryKey)
  if (length(l$primaryKey) == 1) {
    l$fields[
      which(l$fields$name == l$primaryKey),
      "unique"
    ] <- TRUE
  }

  ### Matrix and Field types ----
  if (any(l$fields$type %in% c("row", "column"))) {
    if (!all(c("row", "column") %in% l$fields$type)) {
      stop("Both row and column should be provided when modelling a matrix")
    }
    if (nrow(l$fields) != 3) {
      stop("A matrix model should have 3 and only 3 fields")
    }
    if (length(unique(l$fields$type)) != 3) {
      stop(paste(
        "A matrix model should have 3 fields":"2 of types 'row' and 'column' and the 3rd of your choice"
      ))
    }
    rcfields <- l$fields |> dplyr::filter(.data$type %in% c("row", "column"))
    if (any(rcfields$nullable)) {
      stop("Matrix row and column cannot be nullable")
    }
    if (any(rcfields$unique)) {
      stop(paste(
        "The combination of row and column is unique (primary key)",
        " but not row names and column names independently"
      ))
    }
    l$primaryKey <- rcfields$name
    if (setdiff(l$fields$type, c("row", "column")) == "base64") {
      stop("A matrix cannot store base64 documents")
    }
    check_types(setdiff(l$fields$type, c("row", "column")))
  } else {
    check_types(l$fields$type)
  }

  ### Foreign keys ----
  if (!is.null(l$foreignKeys)) {
    stopifnot(is.list(l$foreignKeys))
    fkn <- c("refTable", "key")
    l$foreignKeys <- lapply(
      l$foreignKeys,
      function(fko) {
        fk <- fko[fkn]
        stopifnot(
          all(names(fk) %in% fkn),
          all(fkn %in% names(fk)),
          !is.na(fk$refTable),
          is.character(fk$refTable),
          length(fk$refTable) == 1,
          !is.na(fk$refTable),
          is.data.frame(fk$key),
          all(c("from", "to") %in% names(fk$key)),
          all(names(fk$key) %in% c("from", "to")),
          is.character(fk$key$from),
          all(!is.na(fk$key$from)),
          is.character(fk$key$to),
          all(!is.na(fk$key$to)),
          all(fk$key$from %in% l$fields$name)
        )
        for (att in setdiff(
          names(attributes(fk$key)),
          c("row.names", "names", "class")
        )) {
          attr(fk$key, att) <- NULL
        }
        fk$key <- dplyr::as_tibble(fk$key)
        cnames <- c("fmin", "fmax", "tmin", "tmax")
        if ("cardinality" %in% names(fko)) {
          stopifnot(
            is.integer(fko$cardinality),
            length(fko$cardinality) == 4,
            all(
              cnames %in%
                names(fko$cardinality)
            ),
            all(!is.na(fko$cardinality)),
            all(fko$cardinality >= -1),
            fko$cardinality["fmin"] > -1,
            fko$cardinality["tmin"] > -1,
            fko$cardinality["fmax"] == -1 ||
              (fko$cardinality["fmax"] > 0 &&
                fko$cardinality["fmax"] >= fko$cardinality["fmin"]),
            fko$cardinality["tmax"] == -1 ||
              (fko$cardinality["tmax"] > 0 &&
                fko$cardinality["tmax"] >= fko$cardinality["tmin"])
          )
          fk$cardinality <- fko$cardinality[cnames]
        } else {
          fk$cardinality <- c(0, -1, 1, 1)
          names(fk$cardinality) <- cnames
        }
        return(fk)
      }
    )
    names(l$foreignKeys) <- NULL
  }

  ### Indexes ----
  if (!is.null(l$indexes)) {
    stopifnot(is.list(l$indexes))
    # idn <- c("field", "unique")
    idn <- c("fields", "unique")
    l$indexes <- lapply(
      l$indexes,
      function(ind) {
        stopifnot(
          is.list(ind),
          all(names(ind) %in% idn),
          all(idn %in% names(ind)),
          is.character(ind$fields),
          all(!is.na(ind$fields)),
          is.logical(ind$unique),
          all(!is.na(ind$unique)),
          length(ind$unique) == 1,
          all(ind$fields %in% l$fields$name)
        )
        ind$fields <- unique(ind$fields)
        return(ind)
      }
    )
  }

  ### Display ----
  if (is.null(l$display)) {
    l$display <- list(
      x = as.numeric(NA),
      y = as.numeric(NA),
      color = as.character(NA),
      comment = as.character(NA)
    )
  }
  stopifnot(is.list(l$display))
  dn <- c("x", "y", "color", "comment")
  stopifnot(
    all(names(l$display) %in% dn),
    all(dn %in% names(l$display)),
    is.numeric(l$display$x),
    is.numeric(l$display$y),
    is.character(l$display$color),
    is.character(l$display$comment),
    all(unlist(lapply(l$display, length)) == 1)
  )

  ############################################################################@
  ## Creating the object ----
  toRet <- l
  class(toRet) <- c("RelTableModel", class(toRet))
  toRet <- correct_constraints(toRet)
  return(toRet)
}

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

###############################################################################@
#' Check if the object is a [RelTableModel] matrix object
#'
#' A matrix model is a special [RelTableModel] object with 3 and only 3 fields:
#' 2 of types 'row' and 'column' and the 3rd of your choice.
#'
#' @param x any object
#'
#' @return A single logical: TRUE if x is a [RelTableModel] matrix object
#'
#' @export
#'
is.MatrixModel <- function(x) {
  inherits(x, "RelTableModel") &&
    "row" %in% x$fields$type
}

###############################################################################@
#' Format a [RelTableModel] object for printing
#'
#' @param x a [RelTableModel] object
#' @param ... for generics compatibility (not used)
#'
#' @return A single character
#'
#' @export
#'
format.RelTableModel <- function(x, ...) {
  f <- x$fields
  pk <- x$primaryKey
  it <- index_table(x)
  ind <- NULL
  # uq <- NULL
  if (!is.null(it)) {
    it <- it |> dplyr::filter(.data$index != 0)
    ind <- unique(it$field)
    # uq <- unique(it$field[which(it$unique)])
  }
  f$i <- unlist(lapply(
    f$name,
    function(n) {
      paste(sort(it$index[which(it$field == n)]), collapse = ",")
    }
  ))
  toRet <- paste0(
    sprintf(
      "Table name: %s%s",
      x$tableName,
      ifelse(is.MatrixModel(x), " (matrix)", "")
    ),
    "\n",
    paste(
      apply(
        f,
        1,
        function(y) {
          toRet <- "   "
          toRet <- paste0(
            toRet,
            ifelse(y[1] %in% pk, "*", " "),
            # ifelse(y[1] %in% uq, "+ ", "  "),
            ifelse(y[4] == "TRUE" & !y[1] %in% pk, "+ ", "  "),
            y[1]
          )
          toRet <- paste0(
            toRet,
            " (",
            y[2],
            ifelse(
              y[1] %in% ind,
              # paste0(", idx.", y[5]),
              paste0(", idx.", y[6]),
              ""
            ),
            ifelse(y[3] == "FALSE", ", not", ","),
            " nullable",
            ")"
          )
          return(toRet)
        }
      ),
      collapse = "\n"
    )
  )
  if (length(x$foreignKeys) > 0) {
    toRet <- paste0(
      toRet,
      "\n",
      "Referenced tables:\n",
      paste(
        unlist(lapply(
          x$foreignKeys,
          function(y) {
            y$refTable
          }
        )),
        collapse = "\n"
      )
    )
  }
  return(toRet)
}

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


###############################################################################@
#' @export
#'
length.RelTableModel <- function(x) {
  nrow(x$fields)
}


###############################################################################@
#' @export
#'
lengths.RelTableModel <- function(x, use.names = TRUE) {
  lengths(unclass(x), use.names = use.names)
}


###############################################################################@
#' List indexes of a [RelTableModel] object
#'
#' @param x a [RelTableModel] object
#'
#' @return A tibble with the following columns:
#' - **index**: an integer corresponding to the index number
#' - **field**: a character corresponding to field belonging to the index
#' - **unique**: a logical indicating the uniqueness of the field
#'
#' @export
#'
index_table <- function(x) {
  stopifnot(is.RelTableModel(x))
  pk <- x$primaryKey
  ind <- x$indexes
  toRet <- NULL
  i <- 0
  if (length(pk) > 0) {
    toRet <- dplyr::tibble(
      index = i,
      field = pk,
      # unique=length(pk)==1
      uniqueIndex = TRUE
    )
  }
  for (ci in ind) {
    i <- i + 1
    toRet <- dplyr::bind_rows(
      toRet,
      dplyr::tibble(
        index = i,
        field = ci$fields,
        uniqueIndex = ci$unique
      )
    )
  }
  return(toRet)
}

###############################################################################@
#' Get the types of the columns of a [RelTableModel] object
#'
#' @param x a [RelTableModel] object
#'
#' @return A col_spec object with the type of each column
#'
#' @export
#'
col_types <- function(x) {
  stopifnot(is.RelTableModel(x))
  do.call(
    readr::cols,
    structure(
      lapply(
        x$fields$type,
        function(y) {
          switch(
            y,
            "row" = readr::col_character(),
            "column" = readr::col_character(),
            "integer" = readr::col_integer(),
            "numeric" = readr::col_double(),
            "logical" = readr::col_logical(),
            "character" = readr::col_character(),
            "Date" = readr::col_date(),
            "POSIXct" = readr::col_datetime(),
            "base64" = readr::col_character()
          )
        }
      ),
      .Names = x$fields$name
    )
  )
}

###############################################################################@
#' Correct the constraints of a table to make them consistent
#'
#' @param x a [RelTableModel] object
#' @param createPKIndex should an index be create for the primary key
#' (default: FALSE)
#'
#' @export
#'
correct_constraints <- function(x, createPKIndex = FALSE) {
  stopifnot(is.RelTableModel(x))
  ## Primary key uniqueness
  if (length(x$primaryKey) == 1) {
    x$fields[which(x$fields$name == x$primaryKey), "unique"] <- TRUE
    x$fields[which(x$fields$name == x$primaryKey), "nullable"] <- FALSE
  }
  if (length(x$primaryKey) > 0) {
    ei <- lapply(
      x$indexes,
      function(y) {
        identical(sort(y$fields), sort(x$primaryKey))
      }
    ) |>
      unlist() |>
      as.logical() |>
      which()
    if (length(ei) > 1) {
      stop("Check this part of code")
    }
    if (length(ei) == 0) {
      if (createPKIndex) {
        x$indexes <- unique(c(
          x$indexes,
          list(
            list(
              fields = sort(x$primaryKey),
              unique = TRUE
            )
          )
        ))
      }
    } else {
      x$indexes[[ei]]$unique <- TRUE
    }
  }
  ## Index uniqueness
  if (length(x$indexes) > 0) {
    for (i in 1:length(x$indexes)) {
      if (x$indexes[[i]]$unique && length(x$indexes[[i]]$fields) == 1) {
        if (
          x$fields[
            which(x$fields$name == x$indexes[[i]]$fields),
            "type"
          ] %in%
            c("row", "column")
        ) {
          stop("Matrix row and column cannot be unique individually")
        }
        x$fields[
          which(x$fields$name == x$indexes[[i]]$fields),
          "unique"
        ] <- TRUE
      }
    }
  }
  ## Field uniqueness
  uniqueFields <- x$fields |>
    dplyr::filter(.data$unique) |>
    dplyr::pull("name")
  if (length(x$indexes) > 0 && length(uniqueFields) > 0) {
    for (i in 1:length(x$indexes)) {
      if (any(x$indexes[[i]]$fields %in% uniqueFields)) {
        x$indexes[[i]]$unique <- TRUE
      }
    }
  }
  ##
  return(x)
}

###############################################################################@
#' Confront a [RelTableModel] to actual data
#'
#' @param x a [RelTableModel]
#' @param d a data frame or a matrix for matrix model
#' @param checks a character vector with the name of optional checks to be done
#' (Default: all of them c("unique", "not nullable"))
#'
#' @return A report as a list
#'
#' @export
#'
confront_table_data <- function(
  x,
  d,
  checks = c("unique", "not nullable")
) {
  ## Optional checks ----
  if (length(checks) > 0) {
    checks <- match.arg(
      checks,
      c("unique", "not nullable"),
      several.ok = TRUE
    )
  }
  stopifnot(is.RelTableModel(x))
  ## Matrix model ----
  if (is.MatrixModel(x)) {
    if (!inherits(d, c("matrix", "Matrix"))) {
      stop(x$tableName, " is neither a matrix nor a Matrix")
    }
    vf <- x$fields |> dplyr::filter(!.data$type %in% c("row", "column"))
    toRet <- list(
      missingFields = character(0),
      suppFields = character(0),
      availableFields = vf$name,
      fields = list(),
      success = TRUE
    )
    toRet$fields[[vf$name]] <- list(success = TRUE, message = NULL)
    if (!inherits(d[1], vf$type)) {
      toRet$fields[[vf$name]]$success <- FALSE
      toRet$success <- FALSE
      toRet$fields[[vf$name]]$message <- paste(
        c(
          toRet$fields[[vf$name]]$message,
          sprintf(
            'Unexpected "%s"',
            paste(class(d[1]), collapse = ", ")
          )
        ),
        collapse = " "
      )
    }
    if ("not nullable" %in% checks) {
      mis <- sum(is.na(d))
      if (mis != 0) {
        toRet$fields[[vf$name]]$message <- paste(
          c(
            toRet$fields[[vf$name]]$message,
            sprintf(
              'Missing values %s/%s = %s%s',
              mis,
              length(d),
              round(mis * 100 / length(d)),
              "%"
            )
          ),
          collapse = " "
        )
        if (!vf$nullable) {
          toRet$fields[[vf$name]]$success <- FALSE
          toRet$success <- FALSE
        }
      }
    }
    if ("unique" %in% checks && vf$unique && any(duplicated(d))) {
      toRet$fields[[vf$name]]$success <- FALSE
      toRet$success <- FALSE
      toRet$fields[[vf$name]]$message <- paste(
        c(
          toRet$fields[[vf$name]]$message,
          "Some values are duplicated"
        ),
        collapse = " "
      )
    }
    return(toRet)
  }

  if (!inherits(d, "data.frame")) {
    stop(x$tableName, " is not a data.frame")
  }
  ## Available fields ----
  missingFields <- setdiff(x$fields$name, colnames(d))
  suppFields <- setdiff(colnames(d), x$fields$name)
  availableFields <- intersect(colnames(d), x$fields$name)
  toRet <- list(
    missingFields = missingFields,
    suppFields = suppFields,
    availableFields = availableFields,
    fields = list(),
    success = length(missingFields) == 0 && length(suppFields) == 0
  )
  ## Fields ----
  for (fn in availableFields) {
    ft <- x$fields$type[which(x$fields$name == fn)]
    ft <- ifelse(ft %in% c("row", "column"), "character", ft)
    fe <- x$fields$nullable[which(x$fields$name == fn)]
    fu <- x$fields$unique[which(x$fields$name == fn)]
    toRet$fields[[fn]] <- list(success = TRUE, message = NULL)
    if (!inherits(dplyr::pull(d, !!fn), ft)) {
      if (ft != "base64" || !inherits(dplyr::pull(d, !!fn), "character")) {
        toRet$fields[[fn]]$success <- FALSE
        toRet$success <- FALSE
        toRet$fields[[fn]]$message <- paste(
          c(
            toRet$fields[[fn]]$message,
            sprintf(
              'Unexpected "%s"',
              paste(class(dplyr::pull(d, !!fn)), collapse = ", ")
            )
          ),
          collapse = " "
        )
      }
    }
    if ("not nullable" %in% checks) {
      mis <- sum(is.na(dplyr::pull(d, !!fn)))
      if (mis != 0) {
        toRet$fields[[fn]]$message <- paste(
          c(
            toRet$fields[[fn]]$message,
            sprintf(
              'Missing values %s/%s = %s%s',
              mis,
              nrow(d),
              round(mis * 100 / nrow(d)),
              "%"
            )
          ),
          collapse = " "
        )
        if (!fe) {
          toRet$fields[[fn]]$success <- FALSE
          toRet$success <- FALSE
        }
      }
    }
    toTest <- dplyr::pull(d, !!fn)
    toTest <- toTest[which(!is.na(toTest))]
    if ("unique" %in% checks && fu && any(duplicated(toTest))) {
      toRet$fields[[fn]]$success <- FALSE
      toRet$success <- FALSE
      toRet$fields[[fn]]$message <- paste(
        c(
          toRet$fields[[fn]]$message,
          "Some values are duplicated"
        ),
        collapse = " "
      )
    }
  }
  ## Indexes ----
  if ("unique" %in% checks && length(x$indexes) > 0) {
    toRet$indexes <- list()
    for (i in 1:length(x$indexes)) {
      toRet$indexes[[i]] <- list()
      idx <- x$indexes[[i]]
      if (any(idx$fields %in% missingFields)) {
        toRet$indexes[[i]]$success <- FALSE
        toRet$indexes[[i]]$message <- paste(
          c(
            toRet$indexes[[i]]$message,
            "Missing field"
          ),
          collapse = " "
        )
        toRet$success <- FALSE
      } else {
        if (!idx$unique) {
          toRet$indexes[[i]]$success <- TRUE
        } else {
          toTest <- dplyr::filter(
            d[, idx$fields],
            stats::complete.cases(d[, idx$fields])
          )
          if (nrow(dplyr::distinct(toTest)) != nrow(toTest)) {
            toRet$indexes[[i]]$success <- FALSE
            toRet$indexes[[i]]$message <- paste(
              c(
                toRet$indexes[[i]]$message,
                "Some values are duplicated"
              ),
              collapse = " "
            )
            toRet$success <- FALSE
          } else {
            toRet$indexes[[i]]$success <- TRUE
          }
        }
      }
    }
  }
  if ("not nullable" %in% checks && is.MatrixModel(x)) {
    if (!"indexes" %in% names(toRet)) {
      toRet$indexes <- list()
    }
    i <- length(toRet$indexes) + 1
    rf <- x$fields |>
      dplyr::filter(.data$type == "row") |>
      dplyr::pull("name")
    cf <- x$fields |>
      dplyr::filter(.data$type == "column") |>
      dplyr::pull("name")
    fe <- x$fields |>
      dplyr::filter(!.data$type %in% c("row", "column")) |>
      dplyr::pull("nullable")
    ncells <- length(unique(d[, rf])) * length(unique(d[, cf]))
    mis <- ncells - nrow(d)
    if (mis > 0) {
      toRet$indexes[[i]]$message <- paste(
        c(
          toRet$indexes[[i]]$message,
          sprintf(
            'Missing cells %s/%s = %s%s',
            mis,
            ncells,
            round(mis * 100 / ncells),
            "%"
          )
        ),
        collapse = " "
      )
      if (!fe) {
        toRet$indexes[[i]]$success <- FALSE
        toRet$success <- FALSE
      }
    }
  }

  ## Return the results ----
  return(toRet)
}


###############################################################################@
#' Check if two [RelTableModel] are identical
#'
#' @param x a [RelTableModel]
#' @param y a [RelTableModel]
#' @param includeDisplay a single logical (default: TRUE) indicating if
#' the display should be included in the comparison
#'
#' @return A logical: TRUE if the 2 models are identical
#'
#' @export
#'
identical_RelTableModel <- function(x, y, includeDisplay = TRUE) {
  stopifnot(is.RelTableModel(x), is.RelTableModel(y))

  ## Name ----
  toRet <- x$tableName == y$tableName

  ## Fields ----
  toRet <- toRet &&
    identical(
      x$fields |> dplyr::arrange(.data$name),
      y$fields |> dplyr::arrange(.data$name)
    )

  ## Primary key ----
  toRet <- toRet &&
    length(x$primaryKey) == length(y$primaryKey) &&
    all(x$primaryKey == y$primaryKey)

  ## Indexes ----
  toRet <- toRet && length(x$indexes) == length(y$indexes)
  if (toRet && length(x$indexes) > 0) {
    # xidx <- lapply(
    #   x$indexes,
    #   function(z) {
    #     z$fields <- sort(z$fields)
    #     return(z)
    #   }
    # )
    xidx <- x$indexes
    xidx <- xidx[order(unlist(lapply(
      xidx,
      function(z) paste(z$fields, collapse = ", ")
    )))]
    # yidx <- lapply(
    #   y$indexes,
    #   function(z) {
    #     z$fields <- sort(z$fields)
    #     return(z)
    #   }
    # )
    yidx <- y$indexes
    yidx <- yidx[order(unlist(lapply(
      yidx,
      function(z) paste(z$fields, collapse = ", ")
    )))]
    toRet <- identical(xidx, yidx)
  }

  ## Foreign keys ----
  toRet <- toRet && length(x$foreignKeys) == length(y$foreignKeys)
  if (toRet && length(x$foreignKeys) > 0) {
    xfk <- lapply(
      x$foreignKeys,
      function(z) {
        z$key <- z$key |> dplyr::arrange(.data$from, .data$to)
        return(z)
      }
    )
    xfk <- xfk[order(unlist(lapply(
      xfk,
      function(z) {
        paste0(
          z$refTable,
          " [",
          paste(
            paste(z$key$from, z$key$to, sep = "->"),
            collapse = ", "
          ),
          "]"
        )
      }
    )))]
    yfk <- lapply(
      y$foreignKeys,
      function(z) {
        z$key <- z$key |> dplyr::arrange(.data$from, .data$to)
        return(z)
      }
    )
    yfk <- yfk[order(unlist(lapply(
      yfk,
      function(z) {
        paste0(
          z$refTable,
          " [",
          paste(
            paste(z$key$from, z$key$to, sep = "->"),
            collapse = ", "
          ),
          "]"
        )
      }
    )))]
    toRet <- identical(xfk, yfk)
  }

  ## Display ----
  if (includeDisplay) {
    toRet <- toRet &&
      length(x$display) == length(y$display) &&
      (length(x$display) == 0 ||
        identical(
          x$display[order(names(x$display))],
          y$display[order(names(y$display))]
        ))
  }
  return(toRet)
}

###############################################################################@
#' Get foreign keys from [RelTableModel]
#'
#' @param x a [RelTableModel]
#'
#' @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.RelTableModel <- function(x) {
  tn <- x$tableName
  fk <- x$foreignKeys
  if (length(fk) == 0) {
    return(NULL)
  }
  toRet <- do.call(
    rbind,
    lapply(
      fk,
      function(k) {
        to <- k$refTable
        kt <- k$key |> dplyr::arrange(.data$from, .data$to)
        dplyr::tibble(
          to = to,
          ff = list(kt$from),
          tf = list(kt$to)
        ) |>
          dplyr::bind_cols(dplyr::as_tibble(t(k$cardinality)))
      }
    )
  )
  toRet <- toRet |>
    dplyr::mutate(
      from = tn
    ) |>
    dplyr::select(
      "from",
      "ff",
      "to",
      "tf",
      "fmin",
      "fmax",
      "tmin",
      "tmax"
    )
  return(toRet)
}