R/clustered.graphs.R

In egor: Import and Analyse Ego-Centered Network Data

#' Cluster ego-centered networks by a grouping factor
#'
#' The idea of clustered graphs is to reduce the complexity of an ego-centered network
#' graph by visualizing alters in clusters defined by a categorical variable (Lerner et al. 2008).
#' \code{clustered_graphs()} calculates group sizes, inter and intra group tie
#' densities and returns these informations in a \code{list} of \code{igraph} objects.
#' @template object
#' @template aaties
#' @template egoID
#' @param clust.groups A \code{character} naming the \code{factor} variable defining the groups.
#' @template meth_dots
#' @references Brandes, U., Lerner, J., Lubbers, M. J., McCarty, C., & Molina,
#' J. L. (2008). Visual Statistics for Collections of Clustered Graphs. 2008
#' IEEE Pacific Visualization Symposium, 47-54.
#' @return \code{clustered_graphs} returns a list of graph objects representing
#' the clustered ego-centered network data;
#' @keywords ego-centered network analysis
#' @seealso \code{\link{vis_clustered_graphs}} for visualizing clustered graphs
#' @example /inst/examples/ex_cg.R
#' @export
clustered_graphs <-
  function(object, ..., clust.groups)
    UseMethod("clustered_graphs", object)

#' @rdname clustered_graphs
#' @export
clustered_graphs.list <-
  function(object, aaties, clust.groups, ...) {
    require_igraph()
    GetGroupSizes <- function(x) {
      if (all(is.na(x[[clust.groups]])))
        return(data.frame(groups = NA, size = NA))
      y <- data.frame(table(x[clust.groups]))
      names(y) <- c("groups", "size")
      y
    }
    
    alters.grped.list <- lapply(object, FUN = GetGroupSizes)
    
    # Exclude NAs in clust.groups
    alters <-
      lapply(
        object,
        FUN = function(y)
          y[!is.na(y[clust.groups][[1]]),]
      )
    
    # Filter out alters in edge list, that are not in alter data
    aaties <- mapply(
      FUN = function(x, y) {
        x <- x[x[[1]] %in% y[[1]],]
        x <- x[x[[2]] %in% y[[1]],]
        x
      },
      aaties,
      alters,
      SIMPLIFY = FALSE
    )
    
    graphs <- mapply(
      FUN = function(x, y)
        igraph::graph.data.frame(
          d = x,
          vertices = y,
          directed = FALSE
        ),
      aaties,
      alters,
      SIMPLIFY = FALSE
    )
    
    # Extracting edges within and between groups ------------------------------
    
    calculateGrpDensities <-
      function(g, alters.group.n, clust.groups) {
        SelectGroupEdges <-
          function(g, clust.groups, group1, group2 = group1) {
            V.group1 <-
              igraph::V(g)[igraph::get.vertex.attribute(g, clust.groups) == group1]
            V.group2 <-
              igraph::V(g)[igraph::get.vertex.attribute(g, clust.groups) == group2]
            igraph::E(g)[(igraph::`%--%`)(V.group1, V.group2)]
          }
        
        
        # Check if all groups are zero sized, if so: return empty entries for grp.df and asdad
        if (length(igraph::V(g)) < 1) {
          groups.list <- list()
          grps.df <-
            data.frame(
              i.name = character(0),
              j.name = character(0),
              grp.size = numeric(0),
              grp.possible.dyads = numeric(0),
              grp.density = numeric(0)
            )
          
          
        } else {
          x_names <-
            names(table(igraph::get.vertex.attribute(g, clust.groups)))
          x_dim <- length(x_names)
          
          for.loop.matrix <- matrix(1, ncol = x_dim, nrow = x_dim)
          colnames(for.loop.matrix) <- x_names
          rownames(for.loop.matrix) <- x_names
          
          groups.list <- list()
          grps.df <- data.frame()
          for (i in 1:x_dim) {
            i.name <- colnames(for.loop.matrix)[i]
            for (j in (1 - 1 + i):(x_dim)) {
              j.name <- rownames(for.loop.matrix)[j]
              ij.name <- paste(i.name, j.name)
              
              groups.list[[ij.name]] <-
                SelectGroupEdges(g, clust.groups, i.name, j.name)
              real.dyads <- length(groups.list[[ij.name]])
              groups.size.i <-
                alters.group.n$size[alters.group.n$groups == i.name]
              groups.size.j <-
                alters.group.n$size[alters.group.n$groups == j.name]
              
              grp.size <-
                ifelse(i.name == j.name,
                       groups.size.i,
                       groups.size.i + groups.size.j)
              
              if (j.name != i.name) {
                grp.possible.dyads <-
                  dyads_possible_between_groups(groups.size.i, groups.size.j)
              } else {
                grp.possible.dyads <- dyad.poss(groups.size.i)
              }
              
              grp.density <- real.dyads / grp.possible.dyads
              grps.df <-
                rbind(
                  grps.df,
                  data.frame(
                    i.name,
                    j.name,
                    grp.size,
                    grp.possible.dyads,
                    grp.density
                  )
                )
            }
          }
          # Check for empty categories and add dummy vertex.
          empty_cats <-
            alters.group.n$groups[!alters.group.n$groups %in% grps.df$i.name]
          if (length(empty_cats) > 0) {
            for (i in 1:length(empty_cats)) {
              empty_dummy <- data.frame(empty_cats[i], empty_cats[i], 0, NaN, NA)
              names(empty_dummy) <- names(grps.df)
              grps.df <- rbind(grps.df, empty_dummy)
            }
          }
        }
        list(grp.densities = grps.df, 
             aatiess = groups.list)
      }
    
    grp.densities <-
      mapply(FUN = calculateGrpDensities,
             graphs,
             alters.grped.list,
             clust.groups,
             SIMPLIFY = FALSE)
    
    # Create 'clustered graphs' igraph object  --------------------------------
    
    clustered_graphs <- lapply(
      grp.densities,
      FUN = function(x)
        igraph::graph.data.frame(
          x$grp.densities[x$grp.densities$i.name != x$grp.densities$j.name, ],
          vertices = x$grp.densities[x$grp.densities$i.name == x$grp.densities$j.name, ],
          directed = FALSE
        )
    )
    map(clustered_graphs, function(x) {
      a <- igraph::vertex_attr(x, "grp.size")
      igraph::set_vertex_attr(x, "grp.prop", value = a/sum(a) * 100)
    })
  }

#' @rdname clustered_graphs
#' @export
clustered_graphs.egor <- function(object, clust.groups, ...) {
  object <- strip_ego_design(as_nested_egor(object))
  clustered_graphs(
    object = object$.alts,
    aaties = object$.aaties,
    clust.groups = clust.groups
  )
}

#' @rdname clustered_graphs
#' @export
clustered_graphs.data.frame <-
  function(object, aaties, clust.groups, egoID = ".egoID", ...) {
    alters <- split(object, object[[egoID]])
    aaties <- split(aaties, aaties[[egoID]])
    alters <- lapply(
      alters,
      FUN = function(x)
        select(x, -.egoID)
    )
    aaties <- lapply(
      aaties,
      FUN = function(x)
        x[2:NCOL(x)]
    )
    
    clustered_graphs(object = alters, 
                     aaties = aaties, 
                     clust.groups = clust.groups)
  }

#' Visualize clustered graphs
#'
#' \code{vis_clustered_graphs} visualizes clustered_graphs using a list of
#' clustered graphs created with \code{\link{clustered_graphs}}.
#' @param graphs \code{List} of \code{graph} objects, representing the clustered
#' graphs.
#' @param node.size.multiplier \code{Numeric} used to multiply the node diameter
#' of visualized nodes.
#' @param node.min.size \code{Numeric} indicating minimum size of plotted
#' nodes
#' @param node.max.size \code{Numeric} indicating maximum size of plotted
#' nodes
#' @param normalise.node.sizes \code{Logical.} If TRUE (default) node sizes
#' are plotted using per network proportions rather than counts.
#' @param edge.width.multiplier \code{Numeric} used to multiply the edge width.
#' @param center \code{Numeric} indicating the vertex to be plotted in center.
#' @param label.size \code{Numeric}.
#' @param labels \code{Boolean}. Plots with turned off labels will be accompanied
#' by a 'legend' plot giving the labels of the vertices.
#' @param legend.node.size \code{Numeric} used as node diameter of legend graph.
#' @param pdf.name \code{Character} giving the name/path of the pdf file to create.
#' @param ... Arguments to pass to `plot.igraph`.
#' @return \code{vis_clustered_graphs} plots
#' a \code{list} of \code{igraph} objects created by the \code{clustered_graphs}
#' function.
#' @references Brandes, U., Lerner, J., Lubbers, M. J., McCarty, C., & Molina,
#' J. L. (2008). Visual Statistics for Collections of Clustered Graphs. 2008
#' IEEE Pacific Visualization Symposium, 47-54.
#' @return \code{clustered_graphs} returns a list of graph objects representing
#' the clustered ego-centered network data;
#' @keywords ego-centered network analysis
#' @seealso \code{\link{clustered_graphs}} for creating clustered graphs objects
#' @example /inst/examples/ex_cg.R
#' @export
vis_clustered_graphs <- function(graphs,
                                 node.size.multiplier = 1,
                                 node.min.size = 0,
                                 node.max.size = 200,
                                 normalise.node.sizes = TRUE,
                                 edge.width.multiplier = 1,
                                 center = 1,
                                 label.size = 0.8,
                                 labels = FALSE,
                                 legend.node.size = 45,
                                 pdf.name = NULL,
                                 ...) {
  require_igraph()
  
  plotLegendGraph <- function(grps.graph, center) {
    # set all edges to 1
    vertex_names <- names(igraph::V(grps.graph))
    vertex_df <- data.frame(x1 = vertex_names)
    vertex_length <- length(vertex_names)
    edges_mat <-
      matrix(
        1,
        nrow = vertex_length,
        ncol = vertex_length,
        dimnames = list(vertex_names, vertex_names)
      )
    diag(edges_mat) <- 0
    edges_mat[upper.tri(edges_mat)] <- 0
    edges_graph <- igraph::graph_from_adjacency_matrix(edges_mat)
    edge_list <-
      igraph::ends(edges_graph, igraph::E(edges_graph), names = TRUE)
    grps.graph <-
      igraph::graph.data.frame(d = edge_list,
                               vertices = vertex_df,
                               directed = FALSE)
    
    igraph::plot.igraph(
      grps.graph,
      vertex.color = "grey",
      vertex.frame.color = NA,
      vertex.size = legend.node.size,
      edge.width = 1,
      vertex.label.color = "black",
      vertex.label.cex = label.size,
      vertex.label.family = "sans",
      
      layout = rotate_to_equilibrium(layout_),
      ...
    )
  }
  
  plotGraph <- function(graph, center, layout) {
    if (labels) {
      vertex.label <- paste(" ",
                            igraph::V(graph)$grp.size,
                            round(igraph::V(graph)$grp.density, digits = 2),
                            sep = "\n")
      vertex.label.b <-
        paste(igraph::V(graph)$name, " ",  " ", sep = "\n")
      edge.label <-
        ifelse(
          igraph::E(graph)$grp.density == 0,
          "" ,
          round(igraph::E(graph)$grp.density, digits = 2)
        )
      
      #' @importFrom grDevices gray
      grey.shades <-
        gray(seq(1, 0, -0.008))[igraph::V(graph)$grp.density * 100 + 1]
      grey.shades <-
        strtoi(substr(
          gsub("#", replacement = "0x", grey.shades),
          start = 1,
          stop = 4
        ))
      label.shades <- ifelse(grey.shades < 120, "#cccccc", "black")
      label.shades.b <- ifelse(grey.shades > 120, "white", "black")
      if (length(label.shades) == 0)
        label.shades <- "black"
    } else {
      vertex.label <- NA
      vertex.label.b <- NA
      edge.label <- NA
      label.shades <- NA
    }
    
    if (!normalise.node.sizes) {
      vertex.size <-
        igraph::V(graph)$grp.size * node.size.multiplier + node.min.size
    } else {
      vertex.size <-
        igraph::V(graph)$grp.prop * node.size.multiplier + node.min.size
    }
    vertex.size[vertex.size > node.max.size] <- node.max.size

    betw_grp_dens <- igraph::E(graph)$grp.density
    betw_grp_dens_color <- 
      if(all(betw_grp_dens == 0) || length(betw_grp_dens) == 0) {
        gray(1, alpha = 0.7)
      } else {
        gray(1 - betw_grp_dens / max(betw_grp_dens), alpha = 0.7)
        }
       
    
    igraph::plot.igraph(
      graph,
      vertex.color = gray(seq(1, 0,-0.008))[igraph::V(graph)$grp.density *
                                              100 + 1],
      vertex.frame.color = "darkslategrey",
      vertex.size = vertex.size,
      vertex.label.color = label.shades,
      vertex.label.cex = label.size,
      vertex.label = vertex.label,
      vertex.label.family = "sans",
      vertex.label.font = 1,
      edge.width = igraph::E(graph)$grp.density * edge.width.multiplier,
      edge.arrow.size = 0,
      edge.label = edge.label,
      edge.label.color = "black",
      edge.label.cex = edge.label.cex,
      edge.label.family = "sans",
      edge.color = betw_grp_dens_color,
      layout = layout,
      ...
    )
    
    
    igraph::plot.igraph(
      graph,
      add = TRUE,
      vertex.color = NA,
      vertex.frame.color = NA,
      vertex.size = vertex.size,
      vertex.label.color = label.shades,
      vertex.label.cex = label.size,
      vertex.label = vertex.label.b,
      vertex.label.family = "serif",
      vertex.label.font = 2,
      edge.width = 0,
      edge.color = NA,
      edge.arrow.size = 0,
      layout = layout,
      ...
    )
    
  }
  
  # example graph needs to contain the maximum number of nodes across all graphs
  lg <- lengths(graphs)
  example.graph <- graphs[lg == max(lg)][[1]]
  #center.vertex.max <- length(igraph::V(example.graph))
  
  # create layout to be used by all plots
  if (length(igraph::V(example.graph)) < 4) {
    layout_ <- 
      igraph::layout_in_circle(example.graph) |> 
      rotate_to_equilibrium()
  } else {
    layout_ <- 
      igraph::layout_as_star(example.graph, center = center) |> 
      rotate_to_equilibrium()
  }
  
  if (!missing(pdf.name)) {
    #' @importFrom grDevices pdf
    pdf(file = pdf.name,
        width = 46.81,
        height = 33.11)
    
    page.xy <- din_page_dist(length(graphs) + 1)
    #' @importFrom graphics par
    par(mfrow = c(page.xy[1], page.xy[2]))
  }
  
  if (!labels) {
    plotLegendGraph(example.graph, 1)
  }

  edge.label.cex <- label.size
  edge.label.color <- "black"
    
  for (graph in graphs) {
    this_layout <- layout_[igraph::V(example.graph)$name %in% igraph::V(graph)$name, ]
    
    if (length(igraph::V(graph)) < 1) {
      #' @importFrom graphics plot.new
      plot.new()
    } else {
      plotGraph(graph, center, this_layout)
    }
    
  }
  
  if (!missing(pdf.name)) {
    #' @importFrom grDevices dev.off
    dev.off()
  }
}