R/df_to_model.R

In ReDaMoR: Relational Data Modeler

###############################################################################@
#' Create a [RelDataModel] object from column names of data frames
#'
#' @param ... the data frame objects, as names (unquoted) or character strings
#' (quoted)
#' @param list a character vector naming data frame objects
#' @param pos where to get the objects.
#' By default, uses the current environment.
#' See ‘details’ for other possibilities.
#' @param envir the environment to use. See ‘details’.
#'
#' @details The pos argument can specify the environment from which to get
#' the objects in any of several ways:
#' as an integer (the position in the search list);
#' as the character string name of an element in the search list;
#' or as an environment.
#' The envir argument is an alternative way to specify an environment,
#' but is primarily there for back compatibility.
#'
#' @return A [RelDataModel] object.
#'
#' @example inst/examples/ex_from_df.R
#'
#' @export
#'
df_to_model <- function(
  ...,
  list = character(),
  pos = -1,
  envir = as.environment(pos)
) {
  ## Get object names ----
  ## This part has been taken from the `rm` function
  dots <- match.call(expand.dots = FALSE)$...
  if (
    length(dots) &&
      !all(vapply(
        dots,
        function(x) {
          is.symbol(x) || is.character(x)
        },
        NA,
        USE.NAMES = FALSE
      ))
  ) {
    stop("... must contain names or character strings")
  }
  names <- vapply(dots, as.character, "")
  if (length(names) == 0) {
    names <- character()
  }
  list <- c(list, names) |> unique()
  ## Get and check object values ----
  values <- lapply(list, get, envir = envir, mode = "any", inherits = TRUE)
  names(values) <- list
  isdf <- lapply(
    values,
    inherits,
    c("data.frame", "matrix", "Matrix")
  ) |>
    unlist()
  if (any(!isdf)) {
    stop(
      "The following objects are neither of class ",
      "data.frame, matrix nor Matrix: ",
      paste(names(isdf)[!isdf], collapse = ", ")
    )
  }
  ## Build the data model ----
  toRet <- list()
  for (tn in names(values)) {
    df <- values[[tn]]
    if (inherits(df, c("matrix", "Matrix"))) {
      toRet[[tn]] <- RelTableModel(
        tableName = tn,
        fields = dplyr::tibble(
          name = c("row", "column", "value"),
          type = c("row", "column", class(df[1])),
          nullable = c(FALSE, FALSE, TRUE),
          unique = c(FALSE, FALSE, FALSE),
          comment = as.character(NA)
        ),
        primaryKey = c("row", "column"),
        foreignKeys = NULL,
        indexes = NULL,
        display = list(
          x = as.numeric(NA),
          y = as.numeric(NA),
          color = as.character(NA),
          comment = as.character(NA)
        )
      )
    } else {
      types <- character()
      for (cn in colnames(df)) {
        ct <- (df |> dplyr::pull(!!cn) |> class())[1]
        if (!ct %in% SUPPTYPES) {
          stop(
            sprintf(
              'Type "%s" of column "%s" is not supported. ',
              ct,
              cn
            ),
            'Supported types are provided in "SUPPTYPES".'
          )
        }
        types <- c(types, ct)
      }
      toRet[[tn]] <- RelTableModel(
        tableName = tn,
        fields = dplyr::tibble(
          name = colnames(df),
          type = types,
          nullable = TRUE,
          unique = FALSE,
          comment = as.character(NA)
        ),
        primaryKey = NULL,
        foreignKeys = NULL,
        indexes = NULL,
        display = list(
          x = as.numeric(NA),
          y = as.numeric(NA),
          color = as.character(NA),
          comment = as.character(NA)
        )
      )
    }
  }
  return(RelDataModel(toRet))
}

###############################################################################@
#' Guess [RelDataModel] constraints based on the provided or existing tables
#'
#' @param x a [RelDataModel]
#' @param data a named list of tables. All names of x should exist in data. If
#' NULL, the data are taken from env.
#' @param env the R environment in which to find the tables
#' @param constraints the type of constraints to guess
#'
#' @return A [RelDataModel]
#'
#' @details
#' The guessed constraints should be carefully review, especially the foreign
#' keys.
#'
#' Complex foreign keys involving multiple fields are not guessed.
#'
#' @example inst/examples/ex_from_df.R
#'
#' @export
#'
guess_constraints <- function(
  x,
  data = NULL,
  env = parent.frame(n = 1),
  constraints = c("unique", "not nullable", "foreign keys")
) {
  dml <- unclass(x)
  if (is.null(data)) {
    data <- lapply(names(x), get, envir = env) |>
      stats::setNames(names(x))
  }
  stopifnot(all(names(x) %in% names(data)))
  stopifnot(all(unlist(
    lapply(data, inherits, what = c("matrix", "Matrix", "data.frame"))
  )))
  for (n in names(dml)) {
    d <- data[[n]]
    if (is.data.frame(d)) {
      if ("not nullable" %in% constraints) {
        nullable <- lapply(
          d,
          function(x) any(is.na(x))
        ) |>
          unlist()
        dml[[n]]$fields$nullable <- nullable
      }
      if ("unique" %in% constraints) {
        uni <- lapply(
          d,
          function(x) !is.numeric(x) && !any(duplicated(x))
        ) |>
          unlist()
        dml[[n]]$fields$unique <- uni
      }
    } else {
      if ("not nullable" %in% constraints) {
        nullable <- any(is.na(d))
        dml[[n]]$fields$nullable[which(
          !dml[[n]]$fields$type %in% c("row", "column")
        )] <- nullable
      }
    }
  }
  dm <- RelDataModel(dml)
  if ("foreign keys" %in% constraints) {
    dbm <- toDBM(dm)
    pfk <- dplyr::inner_join(
      dbm$fields |>
        dplyr::filter(!.data$nullable & .data$unique) |>
        select(-"nullable", -"unique", -"comment", -"fieldOrder"),
      dbm$fields |>
        select(-"comment", -"fieldOrder"),
      by = c("name", "type"),
      suffix = c(".p", ".f"),
      relationship = "many-to-many"
    ) |>
      dplyr::filter(.data$table.p != .data$table.f)
    if (nrow(pfk) > 0) {
      drows <- lapply(data, nrow) |> unlist()
      pfk <- pfk |>
        dplyr::mutate(
          nrow.p = drows[.data$table.p],
          nrow.f = drows[.data$table.f]
        ) |>
        dplyr::filter(
          !.data$unique | .data$nrow.f <= .data$nrow.p
        )
      if (nrow(pfk) > 0) {
        for (i in 1:nrow(pfk)) {
          if (
            all(
              setdiff(data[[pfk$table.f[i]]][[pfk$name[i]]], NA) %in%
                data[[pfk$table.p[i]]][[pfk$name[i]]]
            )
          ) {
            dm <- add_foreign_key(
              dm,
              fromTable = pfk$table.f[i],
              fromFields = pfk$name[i],
              toTable = pfk$table.p[i],
              toFields = pfk$name[i],
              tmin = ifelse(pfk$nullable[i], 0L, 1L)
            )
          }
        }
      }
    }
  }
  return(dm)
}