R/transitive_reduction.R

In ISMtools: Interpretive Structural Modelling Analysis Tools

#' Extract Direct Edges (Transitive Reduction)
#'
#' Performs transitive reduction on a reachability matrix to extract only the
#' direct (essential) edges, removing edges that can be inferred through
#' transitive paths.
#'
#' @param reach_matrix A square reachability matrix (n x n) with 0/1 entries.
#' @param adj_matrix Optional. The original adjacency matrix. If provided,
#'   the function will use it to identify direct edges more accurately.
#'
#' @return A matrix of the same dimension containing only direct edges (1s where
#'   there is a direct relationship that cannot be inferred from other paths).
#'
#' @details
#' Transitive reduction removes redundant edges from a directed graph while
#' preserving reachability. An edge (i,j) is considered redundant (transitive)
#' if there exists another path from i to j through intermediate nodes.
#'
#' For example, if A->B->C and A->C, the edge A->C is transitive and will be
#' removed, leaving only A->B and B->C.
#'
#' This is essential for creating clean ISM diagrams suitable for publications,
#' as showing all reachability edges would result in cluttered graphs.
#'
#' @seealso
#' \code{\link{identify_transitive_edges}} for identifying (not removing) transitive edges,
#' \code{\link{plot_ism}} which uses this function internally.
#'
#' @export
#' @examples
#' # Create adjacency matrix with a transitive edge
#' # A -> B -> C, and A -> C (transitive)
#' adj <- matrix(c(0, 1, 1,
#'                 0, 0, 1,
#'                 0, 0, 0), nrow = 3, byrow = TRUE)
#' rownames(adj) <- colnames(adj) <- c("A", "B", "C")
#'
#' # Compute reachability
#' reach <- compute_reachability(adj)
#' print(reach)
#'
#' # Extract direct edges only
#' direct <- extract_direct_edges(reach)
#' print(direct)
#' # A->C is removed because it's transitive through B
extract_direct_edges <- function(reach_matrix, adj_matrix = NULL) {
  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)
  }

  n <- nrow(reach_matrix)
  dn <- dimnames(reach_matrix)

  # Work with a copy, remove self-loops
  work_matrix <- reach_matrix
  diag(work_matrix) <- 0

  # If original adjacency matrix is provided, start from there
  if (!is.null(adj_matrix)) {
    result <- adj_matrix
    diag(result) <- 0
  } else {
    result <- work_matrix
  }

  # For each edge (i,j), check if there's an alternative path
  # An edge is transitive if there exists k such that:
  # reach_matrix[i,k] == 1 AND reach_matrix[k,j] == 1 AND k != i AND k != j
  for (i in seq_len(n)) {
    for (j in seq_len(n)) {
      if (i != j && result[i, j] == 1) {
        # Check for intermediate nodes
        for (k in seq_len(n)) {
          if (k != i && k != j) {
            # If i can reach k and k can reach j, then i->j is transitive
            if (work_matrix[i, k] == 1 && work_matrix[k, j] == 1) {
              result[i, j] <- 0
              break
            }
          }
        }
      }
    }
  }

  dimnames(result) <- dn
  return(result)
}

#' Identify Transitive Edges
#'
#' Identifies which edges in a reachability matrix are transitive (can be
#' inferred from other paths) versus direct (essential).
#'
#' @param reach_matrix A square reachability matrix (n x n) with 0/1 entries.
#' @param adj_matrix Optional. The original adjacency matrix for comparison.
#'
#' @return A data frame with columns:
#'   \itemize{
#'     \item \code{from}: source node index
#'     \item \code{to}: target node index
#'     \item \code{from_label}: source node label (if available)
#'     \item \code{to_label}: target node label (if available)
#'     \item \code{type}: "direct" or "transitive"
#'   }
#'
#' @details
#' This function is useful for understanding the structure of relationships
#' and for creating visualizations where transitive edges are shown differently
#' (e.g., as dashed lines) from direct edges.
#'
#' @seealso
#' \code{\link{extract_direct_edges}} for removing transitive edges,
#' \code{\link{plot_ism}} for visualization.
#'
#' @export
#' @examples
#' adj <- matrix(c(0, 1, 1,
#'                 0, 0, 1,
#'                 0, 0, 0), nrow = 3, byrow = TRUE)
#' rownames(adj) <- colnames(adj) <- c("A", "B", "C")
#'
#' reach <- compute_reachability(adj)
#' edges <- identify_transitive_edges(reach)
#' print(edges)
identify_transitive_edges <- function(reach_matrix, adj_matrix = NULL) {
  if (!is.matrix(reach_matrix)) {
    stop("Input must be a matrix", call. = FALSE)
  }

  n <- nrow(reach_matrix)
  labels <- rownames(reach_matrix)
  if (is.null(labels)) {
    labels <- as.character(seq_len(n))
  }

  # Get direct edges
  direct_matrix <- extract_direct_edges(reach_matrix, adj_matrix)

  # Get all edges (excluding self-loops)
  work_matrix <- reach_matrix
  diag(work_matrix) <- 0

  all_edges <- which(work_matrix == 1, arr.ind = TRUE)

  if (nrow(all_edges) == 0) {
    return(data.frame(
      from = integer(0),
      to = integer(0),
      from_label = character(0),
      to_label = character(0),
      type = character(0),
      stringsAsFactors = FALSE
    ))
  }

  # Classify each edge
  result <- data.frame(
    from = all_edges[, 1],
    to = all_edges[, 2],
    from_label = labels[all_edges[, 1]],
    to_label = labels[all_edges[, 2]],
    stringsAsFactors = FALSE
  )

  result$type <- ifelse(
    direct_matrix[cbind(result$from, result$to)] == 1,
    "direct",
    "transitive"
  )

  return(result)
}