R/plot.RelDataModel.R

In ReDaMoR: Relational Data Modeler

###############################################################################@
#' Plot a [RelDataModel] object
#'
#' This function draw a visNetwork of the [RelDataModel].
#'
#' @param x a [RelDataModel]
#' @param ... additional parameters:
#' - **color** default table background color
#' - **border** border color (single character)
#' - **highlightBorder** color of highlighted borders
#'
#' @example inst/examples/ex_plot_model.R
#'
#' @export
#'
plot.RelDataModel <- function(
  x,
  ...
) {
  toPlot <- modelToVn(x, ...)

  visNetwork::visNetwork(nodes = toPlot$nodes, edges = toPlot$edges) |>
    visNetwork::visNodes(
      labelHighlightBold = FALSE,
      borderWidth = 2
    ) |>
    visNetwork::visEdges(
      # color=list(
      #    color=border,
      #    highlight=highlightBorder
      # ),
      width = 2,
      selectionWidth = 2
    ) |>
    visNetwork::visInteraction(multiselect = TRUE) |>
    ################################################@
    ## The code below is useless when edge smooth is
    ## define by edge
    # visNetwork::visPhysics(
    #    solver="repulsion",
    #    repulsion=list(
    #       nodeDistance=100,
    #       springLength=100,
    #       springConstant=0.001,
    #       damping=1,
    #       avoidOverlap=1
    #    )
    # ) |>
    ################################################@
    visNetwork::visLayout(randomSeed = 2) |>
    visNetwork::visPhysics(enabled = FALSE)
}

###############################################################################@
#' VisNetwork representation of a [RelDataModel] object
#'
#' @param model a [RelDataModel]
#' @param color default table background color
#' @param border border color (single character)
#' @param highlightBorder color of highlighted borders
#'
#'
#' Internal function
#'
modelToVn <- function(
  model,
  color = "lightgrey",
  border = "black",
  highlightBorder = "orange"
) {
  nodes <- do.call(
    rbind,
    lapply(
      model,
      function(m) {
        f <- m$fields
        pk <- m$primaryKey
        it <- index_table(m)
        ind <- NULL
        # uq <- NULL
        if (!is.null(it) && any(it$index > 0)) {
          it <- it |>
            dplyr::filter(.data$index != 0) |>
            dplyr::group_by(.data$index) |>
            dplyr::mutate(
              n = dplyr::n(),
              nn = 1:dplyr::n()
            ) |>
            dplyr::ungroup() |>
            dplyr::mutate(
              index = ifelse(
                .data$n > 1,
                paste(.data$index, .data$nn, sep = "-"),
                as.character(.data$index)
              )
            )
          ind <- unique(it$field)
          uind <- it |>
            dplyr::filter(.data$uniqueIndex) |>
            dplyr::pull("field") |>
            unique()
          # uq <- unique(it$field[which(it$unique)])
        }
        f$i <- unlist(lapply(
          f$name,
          function(n) {
            paste(sort(it$index[which(it$field == n)]), collapse = ",")
          }
        ))
        flab <- paste(
          sprintf(
            '    - %s%s%s%s%s {%s%s}%s',
            ifelse(f$nullable, "(", ""),
            ifelse(f$name %in% pk, "<b>", ""),
            # ifelse(f$unique & !f$name %in% pk, "*", ""),
            ifelse(f$unique, "*", ""),
            f$name,
            ifelse(f$name %in% pk, "</b>", ""),
            f$type,
            ifelse(
              f$name %in% ind,
              sprintf(
                "<b> - %s</b>",
                ifelse(
                  f$name %in% uind,
                  paste0("uidx.", f$i),
                  paste0("idx.", f$i)
                )
              ),
              ""
            ),
            ifelse(f$nullable, ")", "")
          ),
          collapse = "\n"
        )
        label <- paste(
          sprintf(
            '<b>%s%s</b>',
            m$tableName,
            ifelse(is.MatrixModel(m), " []", "")
          ),
          flab,
          sep = "\n"
        )
        fcomment <- gsub(
          "\\{([^}]*)\\}",
          "<b>{\\1}</b>",
          f$comment
        )
        tcomment <- gsub(
          "\\{([^}]*)\\}",
          "<b>{\\1}</b>",
          m$display$comment
        )
        ftit <- paste(
          sprintf(
            '<li><strong>%s</strong>%s%s</li>',
            f$name,
            ifelse(is.na(f$comment) | f$comment == "", "", ": "),
            ifelse(
              is.na(f$comment) | f$comment == "",
              "",
              fcomment
            )
          ),
          collapse = " "
        )
        title <- paste(
          sprintf(
            paste0(
              '<p><strong style="text-decoration:underline;">%s',
              '</strong>%s</p>'
            ),
            m$tableName,
            ifelse(
              is.na(m$display$comment),
              "",
              sprintf(" (%s)", tcomment)
            )
          ),
          "<ul>",
          ftit,
          "</ul>",
          sep = " "
        )
        title <- sprintf(
          paste0(
            '<div ',
            'style="',
            'max-width:400px; max-height:300px;',
            'overflow-y:auto; overflow-wrap:break-word;',
            'word-break:break-word; white-space:normal;',
            '">%s</div>'
          ),
          title
        )
        return(dplyr::tibble(
          tableName = m$tableName,
          label = label,
          title = title,
          shape = "box",
          font.multi = TRUE,
          font.align = "left",
          x = m$display$x,
          y = m$display$y,
          color.background = m$display$color
        ))
      }
    )
  )
  if (!is.null(nodes) && nrow(nodes) > 0) {
    nodes <- nodes |>
      dplyr::mutate(
        color.border = !!border,
        color.highlight.border = !!highlightBorder,
        color.background = ifelse(
          is.na(.data$color.background),
          !!color,
          .data$color.background
        )
      ) |>
      dplyr::mutate(
        color.highlight.background = .data$color.background
      )
    nodes$id <- names(model)
  }

  edges <- do.call(
    rbind,
    lapply(
      model,
      function(m) {
        mt <- m$tableName
        fk <- m$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)
              kcard <- ifelse(k$cardinality == -1, "n", k$cardinality)
              fcard <- paste(kcard["fmin"], kcard["fmax"], sep = "..")
              tcard <- paste(kcard["tmin"], kcard["tmax"], sep = "..")
              title <- paste0(
                '<tr style="border: 1px solid black; padding:1px;">',
                '<td style="border: 1px solid black; padding:1px;">',
                c(kt$from),
                '</td>',
                '<td style="border: 1px solid black; padding:1px;">',
                c(kt$to),
                '</td>',
                '</tr>'
              )
              title <- paste0(
                '<table style="border: 1px solid black; padding:1px;">',
                '<tr style="border: 1px solid black; padding:1px;">',
                sprintf(
                  paste0(
                    '<th style=',
                    '"border: 1px solid black; padding:1px;',
                    'text-align:center;"',
                    '>',
                    '%s<br>(%s)',
                    '</th>'
                  ),
                  mt,
                  fcard
                ),
                sprintf(
                  paste0(
                    '<th style=',
                    '"border: 1px solid black; padding:1px;',
                    'text-align:center;"',
                    '>',
                    '%s<br>(%s)',
                    '</th>'
                  ),
                  k$refTable,
                  tcard
                ),
                '</tr>',
                paste(title, collapse = ""),
                '</table>'
              )
              id <- paste(kt$from, kt$to, sep = "->")
              id <- paste(id, collapse = " && ")
              id <- paste(to, id, sep = ": ")
              return(dplyr::tibble(
                id = id,
                to = to,
                title = title,
                ff = list(kt$from),
                tf = list(kt$to)
              ))
            }
          )
        )
        toRet$from <- mt
        toRet$id <- paste(mt, toRet$id, sep = "->")
        toRet$arrows <- "to"
        toRet$font.align <- "bottom"
        return(toRet)
      }
    )
  )
  if (is.null(edges)) {
    edges <- dplyr::tibble(
      id = character(),
      from = character(),
      to = character()
    )
  } else {
    edges$smooth.type <- "curvedCCW"
    edges$smooth.roundness <- 0
    edges$selfReferenceSize <- 30
    edges <- dplyr::bind_cols(
      edges,
      edges |>
        dplyr::select("from", "to") |>
        apply(1, function(x) c(sort(x), paste(sort(x), collapse = "<->"))) |>
        t() |>
        (function(x) {
          colnames(x) <- c("uef", "uet", "ue")
          x
        })() |>
        dplyr::as_tibble()
    )
    edges <- edges |>
      dplyr::group_by(.data$ue) |>
      dplyr::mutate(
        smooth.roundness = {
          mr <- min(1, 0.2 * (length(.data$ue) %/% 2))
          seq(-mr, mr, length.out = length(.data$ue))
        },
        selfReferenceSize = {
          seq(30, 50, length.out = length(.data$ue))
        }
      ) |>
      dplyr::ungroup() |>
      dplyr::mutate(
        smooth.roundness = ifelse(
          .data$uef == .data$from,
          .data$smooth.roundness,
          -.data$smooth.roundness
        )
      ) |>
      dplyr::mutate(
        color.color = border,
        color.highlight = highlightBorder
      )
  }

  return(list(nodes = nodes, edges = edges))
}