R/gaps_critical_edges.R

In motifr: Motif Analysis in Multi-Level Networks

#' List gaps
#'
#' List gaps ordered by contribution to a motif. This is a list of ties together
#' with the number of motifs of a given class the dyad would generate by being
#' added to the network.
#'
#' The level parameter determines on which level of the network gaps are
#' analysed. Per default, when ``level = -1``, the first level in the motif
#' which provides exactly two nodes is selected. Use this parameter to specify a
#' level manually. The procedure for determining the level is the same as for
#' the Actor's Choice Model, cf. vignette.
#'
#' Note that this only works for undirected graphs. Regardless of whether the
#' input graph is directed it is treated as undirected graph.
#'
#' @param net network object
#' @param motif motif identifier
#' @param lvl_attr character vector specifying the attribute name where level
#'   information is stored in \code{net}.
#' @param level level of the dyads which shall be considered, or -1 if the level
#'   shall be determined automatically.
#'
#' @return data frame with three columns, listing edges and their contribution
#'   to motifs described by the motif identifier in descending order
#' @export
#'
#' @examples
#' \dontrun{
#' head(identify_gaps(ml_net, motif = "1,2[II.C]"))
#' }
identify_gaps <- function(net,
                          motif,
                          lvl_attr = c("sesType"),
                          level = -1) {
  if (pkg.env$sma$isClosedMotifR(motif, level) == FALSE) {
    stop("The specified motif is not closed. Look for critical_dyads instead.")
  }
  return(edge_contribution(net = net, motif = motif, lvl_attr = lvl_attr, level = level))
}

#' List critical dyads
#'
#' Critical dyads are edges on a specified level which break motifs by being
#' removed from the network.
#'
#' The level parameter determines on which level of the network critical dyads
#' are analysed. Per default, when \code{level = -1}, the first level in the motif
#' which provides exactly two nodes is selected. Use this parameter to specify a
#' level manually. The procedure for determining the level is the same as for
#' the Actor's Choice Model, cf. vignette.
#'
#' Note that this only works for undirected graphs. Regardless of whether the
#' input graph is directed it is treated as undirected graph.
#'
#' @param net network object
#' @param motif motif identifier
#' @param lvl_attr character vector specifying the attribute name where level
#'   information is stored in \code{net}
#' @param level level of the dyads which shall be considered, or -1 if the level
#'   shall be determined automatically.
#'
#' @return data frame with three columns, listing edges and their contribution
#'   to motifs described by the motif identifier in descending order
#' @export
#'
#' @examples
#' \dontrun{
#' head(critical_dyads(ml_net, motif = "1,2[I.C]"))
#' }
critical_dyads <- function(net,
                           motif,
                           lvl_attr = c("sesType"),
                           level = -1) {
  if (pkg.env$sma$isClosedMotifR(motif, level) == TRUE) {
    stop("The specified motif is not open. Look for identify_gaps instead.")
  }
  return(edge_contribution(net = net, motif = motif, lvl_attr = lvl_attr, level = level))
}

#' List edge contribution
#'
#' List gaps ordered by contribution to a motif. This is a list of ties together
#' with the number of motifs of a given class the dyad would generate by being
#' flipped. This is a generalisation of \code{motifr::identify_gaps()} and
#' \code{motifr::criticial_dyads()}.
#'
#' The level parameter determines on which level of the network edge
#' contributions are analysed. Per default, when \code{level = -1}, the first
#' level in the motif which provides exactly two nodes is selected. Use this
#' parameter to specify a level manually. The procedure for determining the
#' level is the same as for the Actor's Choice Model, cf. vignette.
#'
#' Note that this only works for undirected graphs. Regardless of whether the
#' input graph is directed it is treated as undirected graph.
#'
#' @param net network object
#' @param motif motif identifier
#' @param lvl_attr character vector specifying the attribute name where level
#'   information is stored in \code{net}.
#' @param level level of the dyads which shall be considered, or -1 if the level
#'   shall be determined automatically.
#'
#' @return data frame with three columns, listing edges and their contribution
#'   to motifs described by the motif identifier in descending order
#' @export
#'
#' @examples
#' \dontrun{
#' head(edge_contribution(ml_net, "1,2[I.C]"))
#' }
edge_contribution <- function(net,
                              motif,
                              lvl_attr = c("sesType"),
                              level = -1) {
  if (motifr::is.directed(net)) {
    warning(paste(
      "Edge contribution does only make sense for undirected networks.",
      "The given network is automatically treated as an undirected network."
    ))
  }
  py_g <- motifr::to_py_graph(g = net, lvl_attr = lvl_attr, directed = FALSE)
  result <- pkg.env$sma$identifyGapsR(py_g, motif, level = level)
  df <- data.frame(result)
  return(df)
}

#' Plot gaps in network visualisation
#'
#' Note that this only works for undirected graphs. Regardless of whether the
#' input graph is directed it is treated as undirected graph.
#'
#' @param net Statnet network object
#' @param motif Motif to explore gaps in for
#' @param lvl_attr Node attribute specifying level information
#' @param level Focal level for gap analysis
#' @param cutoff Cut-off point in contributions of an edge to the number of
#'   motifs above which to analyse gaps
#' @param ... list of additional parameters to be passed to plotting function
#'   (see \code{motifr::plot_mnet}), e.g. \code{label = TRUE}
#' @param subset_graph Whether to subset the graph to only show nodes involved
#'   in gaps. One of "none" (no subset, default), "partial" (only focal level is
#'   subset) or "focal" (only focal level shown)
#'
#' @return A plot of gaps, sized by weight in a multilevel network
#' @export
#'
#' @examples
#' \dontrun{
#' plot_gaps(ml_net, "1,2[II.C]", level = -1)
#' plot_gaps(ml_net, "1,2[II.C]",
#'   level = -1,
#'   subset_graph = "focal", cutoff = 4, label = TRUE
#' )
#' plot_gaps(ml_net, "1,2[II.C]",
#'   level = -1,
#'   subset_graph = "partial", cutoff = 4, label = TRUE
#' )
#' }
plot_gaps <- function(net,
                      motif,
                      lvl_attr = c("sesType"),
                      level = -1,
                      cutoff = 2,
                      subset_graph = "none",
                      ...) {
  gaps <- motifr::identify_gaps(
    net = net,
    motif = motif,
    lvl_attr = lvl_attr,
    level = level
  )

  plot_gaps_or_critical_dyads(net,
    gaps,
    "#f2790070",
    "Gap",
    lvl_attr = lvl_attr,
    cutoff = cutoff,
    subset_graph = subset_graph,
    ...
  )
}

#' Plot critical dyads in network visualisation
#'
#' Note that this only works for undirected graphs. Regardless of whether the
#' input graph is directed it is treated as undirected graph.
#'
#' @param net Statnet network object
#' @param motif Motif to explore gaps in for
#' @param lvl_attr Node attribute specifying level information
#' @param level Focal level for gap analysis
#' @param cutoff Cut-off point in contributions of an edge to the number of
#'   motifs above which to analyse gaps
#' @param ... list of additional parameters to be passed to plotting function
#'   (see \code{motifr::plot_mnet}), e.g. \code{label = TRUE}
#' @param subset_graph Whether to subset the graph to only show nodes involved
#'   in gaps. One of "none" (no subset, default), "partial" (only focal level is
#'   subset) or "focal" (only focal level shown)
#'
#' @return A plot of gaps, sized by weight in a multilevel network
#' @export
#'
#' @examples
#' \dontrun{
#' plot_critical_dyads(ml_net, "1,2[I.C]", level = -1)
#' plot_critical_dyads(ml_net, "1,2[I.C]",
#'   level = -1,
#'   subset_graph = "focal", cutoff = 4, label = TRUE
#' )
#' plot_critical_dyads(ml_net, "1,2[I.C]",
#'   level = -1,
#'   subset_graph = "partial", cutoff = 4, label = TRUE
#' )
#' }
plot_critical_dyads <- function(net,
                                motif,
                                lvl_attr = c("sesType"),
                                level = -1,
                                cutoff = 2,
                                subset_graph = "none",
                                ...) {
  gaps <- motifr::critical_dyads(
    net = net,
    motif = motif,
    lvl_attr = lvl_attr,
    level = level
  )

  plot_gaps_or_critical_dyads(net,
    gaps,
    "#00f24070",
    "Critical dyad",
    lvl_attr = lvl_attr,
    cutoff = cutoff,
    subset_graph = subset_graph,
    ...
  )
}

#' Helper function for plotting gaps and critical edges
#'
#' Note that this only works for undirected graphs. Regardless of whether the
#' input graph is directed it is treated as undirected graph.
#'
#' @seealso \code{plot_gaps}, \code{plot_critical_dyads}.
#'
#' @param net network object
#' @param edge_contribution data frame providing edge contribution data
#' @param colour colour code for the weighted edges
#' @param title title of the plot
#' @param lvl_attr nodal attribute specifying level information
#' @param cutoff Cut-off point in contributions of an edge to the number of
#'   motifs above which to analyse gaps
#' @param ... list of additional parameters to be passed to plotting function
#'   (see \code{motifr::plot_mnet}), e.g. \code{label = TRUE}
#' @param subset_graph Whether to subset the graph to only show nodes involved
#'   in gaps. One of "none" (no subset, default), "partial" (only focal level is
#'   subset) or "focal" (only focal level shown)
#'
#' @return A plot of gaps or critical edges, sized by weight in a multilevel
#'   network
#'
plot_gaps_or_critical_dyads <- function(net,
                                        edge_contribution,
                                        colour,
                                        title,
                                        lvl_attr = c("sesType"),
                                        cutoff = 2,
                                        subset_graph = "none",
                                        ...) {
  edge_contribution <- edge_contribution[edge_contribution$contribution >= cutoff, ]
  max_contribution <- max(edge_contribution$contribution)

  if (cutoff > max_contribution) {
    stop("Cutoff is higher than maximal contribution found")
  }

  gap_nodes <- unique(c(edge_contribution$vertex0, edge_contribution$vertex1))

  if (network::is.network(net)) {
    net <- intergraph::asIgraph(net)
    net <-
      igraph::set.vertex.attribute(net,
        name = "name", value =
          igraph::get.vertex.attribute(net, "vertex.names")
      )
  }

  t_g <- tidygraph::as_tbl_graph(net)
  nodes <- tibble::as_tibble(tidygraph::activate(t_g, nodes))
  edges <- tibble::as_tibble(tidygraph::activate(t_g, edges))

  edges$to_name <- nodes$name[edges$to]
  edges$from_name <- nodes$name[edges$from]

  colnames(nodes)[colnames(nodes) == lvl_attr] <- "sesType"

  gap_level <- unique(nodes$sesType[nodes$name %in% gap_nodes])

  if (subset_graph == "partial") {
    non_focal <- unique(
      edges$to_name[edges$from_name %in% gap_nodes],
      edges$from_name[edges$to_name %in% gap_nodes]
    )
    non_focal <- non_focal[non_focal %in% nodes$name[!(nodes$sesType %in% gap_level)]]
    nodes <- nodes[nodes$name %in% gap_nodes | nodes$name %in% non_focal, ]
    #' @importFrom rlang .data
    t_g <- tidygraph::to_subgraph(t_g, .data$name %in% nodes$name, subset_by = "nodes")$subgraph
  }

  if (subset_graph == "focal") {
    nodes <- nodes[nodes$name %in% gap_nodes, ]
    #' @importFrom rlang .data
    t_g <- tidygraph::to_subgraph(t_g, .data$name %in% nodes$name, subset_by = "nodes")$subgraph
  }

  netviz <- plot_mnet(net = t_g, lvl_attr = lvl_attr, ...)

  # get coordinates for all lines
  coord_gaps <- data.frame(
    x1 =
      unlist(lapply(edge_contribution$vertex0, function(vertex) {
        netviz$data$x[netviz$data$name == vertex]
      })),
    y1 =
      unlist(lapply(edge_contribution$vertex0, function(vertex) {
        netviz$data$y[netviz$data$name == vertex]
      })),
    x2 =
      unlist(lapply(edge_contribution$vertex1, function(vertex) {
        netviz$data$x[netviz$data$name == vertex]
      })),
    y2 =
      unlist(lapply(edge_contribution$vertex1, function(vertex) {
        netviz$data$y[netviz$data$name == vertex]
      })),
    weight = edge_contribution$contribution
  )

  netviz <- netviz +
    ggplot2::geom_segment(
      data = coord_gaps,
      ggplot2::aes_(x = ~x1, y = ~y1, xend = ~x2, yend = ~y2, size = ~weight),
      colour = colour, alpha = 0.7
    )

  netviz$layers <- c(netviz$layers[[1]], netviz$layers[[3]], netviz$layers[[2]])

  break_range <- cutoff:max_contribution

  netviz +
    ggplot2::scale_size_continuous(sprintf("%s weight", title),
      range = c(1, 4),
      breaks = break_range
    )
}