R/plot_interactive.R

In ISMtools: Interpretive Structural Modelling Analysis Tools

#' Interactive ISM Visualization
#'
#' Generates interactive Interpretive Structural Model diagrams with node
#' dragging, zooming, and level-based filtering capabilities. Requires the
#' visNetwork package (suggested dependency).
#'
#' @param reach_matrix A reachability matrix (n x n) representing the ISM
#'   relationships.
#' @param node_labels A character vector of length n specifying custom node
#'   labels. If \code{NULL}, uses matrix row names or numeric indices.
#' @param level_result A list of class \code{ism_levels} representing level
#'   partitioning results from \code{\link{level_partitioning}}. If \code{NULL},
#'   level partitioning is computed automatically.
#' @param show_transitive Logical. If \code{FALSE} (default), transitive edges
#'   are removed for cleaner visualization. If \code{TRUE}, all edges are shown.
#' @param direction Layout direction for visualization. Options:
#'   \itemize{
#'     \item \code{"UD"}: Up-down (default)
#'     \item \code{"LR"}: Left-right
#'     \item \code{"DU"}: Down-up
#'     \item \code{"RL"}: Right-left
#'   }
#'
#' @return An interactive \code{visNetwork} object that can be displayed in
#'   RStudio Viewer, Shiny apps, or web browsers.
#'
#' @details
#' This function requires the \pkg{visNetwork} package. If \pkg{viridis} is
#' available, it will be used for level-based coloring; otherwise, a default
#' color palette is used.
#'
#' The interactive visualization provides several features:
#' \itemize{
#'   \item \strong{Drag nodes}: Click and drag to reposition nodes
#'   \item \strong{Zoom}: Use mouse wheel or navigation buttons
#'   \item \strong{Highlight}: Hover over nodes to highlight connections
#'   \item \strong{Filter}: Select nodes by ID or filter by level group
#'   \item \strong{Keyboard navigation}: Use arrow keys to navigate
#' }
#'
#' By default, transitive edges are removed using \code{\link{extract_direct_edges}}
#' to produce cleaner diagrams. Set \code{show_transitive = TRUE} to show all edges.
#'
#' @seealso
#' \code{\link{plot_ism}} for static visualization,
#' \code{\link{level_partitioning}} for computing hierarchical levels,
#' \code{\link{compute_reachability}} for computing reachability matrices,
#' \code{\link{extract_direct_edges}} for transitive reduction.
#'
#' @export
#' @examples
#' \donttest{
#' # Create sample data
#' adj_matrix <- matrix(c(0, 1, 0, 0,
#'                        0, 0, 1, 1,
#'                        0, 0, 0, 0,
#'                        0, 0, 0, 0), nrow = 4, byrow = TRUE)
#' rownames(adj_matrix) <- colnames(adj_matrix) <- LETTERS[1:4]
#' reach_matrix <- compute_reachability(adj_matrix)
#' levels <- level_partitioning(reach_matrix)
#'
#' # Basic interactive plot (requires visNetwork)
#' if (requireNamespace("visNetwork", quietly = TRUE)) {
#'   plot_interactive_ism(reach_matrix)
#'
#'   # With custom labels and levels
#'   plot_interactive_ism(reach_matrix,
#'                        node_labels = c("Factor A", "Factor B",
#'                                        "Factor C", "Factor D"),
#'                        level_result = levels)
#' }
#' }
plot_interactive_ism <- function(reach_matrix,
                                 node_labels = NULL,
                                 level_result = NULL,
                                 show_transitive = FALSE,
                                 direction = c("UD", "LR", "DU", "RL")) {
  # Check for required package

  if (!requireNamespace("visNetwork", quietly = TRUE)) {
    stop("Package 'visNetwork' is required for interactive visualization.\n",
         "Install with: install.packages('visNetwork')",
         call. = FALSE)
  }

  # Input validation
  if (!is.matrix(reach_matrix)) {
    stop("Input must be a matrix", call. = FALSE)
  }
  if (nrow(reach_matrix) != ncol(reach_matrix)) {
    stop("Matrix must be square", call. = FALSE)
  }

  direction <- match.arg(direction)
  n <- nrow(reach_matrix)

  # Get node labels
  if (is.null(node_labels)) {
    node_labels <- rownames(reach_matrix)
    if (is.null(node_labels)) {
      node_labels <- as.character(seq_len(n))
    }
  }

  # Compute levels if not provided
  if (is.null(level_result)) {
    level_result <- level_partitioning(reach_matrix)
  } else if (!inherits(level_result, "ism_levels")) {
    level_result <- level_partitioning(reach_matrix)
  }

  # Get the matrix to plot (with or without transitive reduction)
  if (show_transitive) {
    plot_matrix <- reach_matrix
    diag(plot_matrix) <- 0
  } else {
    plot_matrix <- extract_direct_edges(reach_matrix)
  }

  # Create nodes data frame
  nodes <- data.frame(
    id = seq_len(n),
    label = node_labels,
    title = paste0("Node: ", node_labels),
    stringsAsFactors = FALSE
  )

  # Add level information
  level_df <- data.frame(
    id = unlist(level_result),
    level = rep(seq_along(level_result), lengths(level_result)),
    stringsAsFactors = FALSE
  )
  nodes <- merge(nodes, level_df, by = "id", all.x = TRUE)
  nodes$group <- paste("Level", nodes$level)

  # Color palette
  n_levels <- length(level_result)
  if (requireNamespace("viridis", quietly = TRUE)) {
    color_pal <- viridis::viridis(n_levels)
  } else {
    # Fallback color palette
    color_pal <- grDevices::hcl.colors(n_levels, palette = "viridis")
  }
  nodes$color <- color_pal[nodes$level]

  # Create edges data frame
  edges_idx <- which(plot_matrix == 1, arr.ind = TRUE)
  if (nrow(edges_idx) > 0) {
    edges <- data.frame(
      from = edges_idx[, 1],
      to = edges_idx[, 2],
      arrows = "to",
      stringsAsFactors = FALSE
    )
  } else {
    edges <- data.frame(
      from = integer(0),
      to = integer(0),
      arrows = character(0),
      stringsAsFactors = FALSE
    )
  }

  # Build visualization using visNetwork functions directly
  net <- visNetwork::visNetwork(nodes, edges, main = "Interactive ISM")
  net <- visNetwork::visHierarchicalLayout(net,
    direction = direction,
    sortMethod = "directed",
    nodeSpacing = 150,
    levelSeparation = 200
  )
  net <- visNetwork::visNodes(net,
    shape = "dot",
    size = 25,
    font = list(size = 18),
    shadow = list(enabled = TRUE, size = 10)
  )
  net <- visNetwork::visEdges(net,
    smooth = list(enabled = TRUE, type = "dynamic"),
    shadow = list(enabled = TRUE)
  )
  net <- visNetwork::visOptions(net,
    highlightNearest = list(enabled = TRUE, degree = 1, hover = TRUE),
    nodesIdSelection = TRUE,
    selectedBy = "group"
  )
  net <- visNetwork::visInteraction(net,
    navigationButtons = TRUE,
    keyboard = TRUE,
    dragNodes = TRUE,
    dragView = TRUE,
    zoomView = TRUE
  )
  net <- visNetwork::visLegend(net,
    enabled = TRUE,
    position = "right"
  )

  return(net)
}