R/vertex_partition.R

In ilovato/nevada: Network-Valued Data Analysis

#' Coercion to Vertex Partition
#'
#' This function converts a vector of memberships into a proper vertex partition
#' object.
#'
#' @param x A list grouping the vertices by partition element or an integer or
#'   character vector of vertex memberships.
#'
#' @return A \code{vertex_partition} object storing the corresponding vertex
#'   partition.
#' @export
#'
#' @examples
#' m1 <- c("P1", "P3", "P4", "P1", "P2", "P2", "P3", "P1", "P4", "P3")
#' V1 <- as_vertex_partition(m1)
#' m2 <- as.integer(c(1, 3, 4, 1, 2, 2, 3, 1, 4, 3))
#' V2 <- as_vertex_partition(m2)
as_vertex_partition <- function(x) {
  UseMethod("as_vertex_partition", x)
}

#' @export
as_vertex_partition.list <- function(x) {
  for (i in 1:length(x)) {
    if (!is.integer(x[[i]]) && !is.character(x[[i]]))
      stop("The element of the list should be either integer or character vectors.")
    if (is.integer(x[[i]])) x[[i]] <- paste0("P", x[[i]])
  }
  class(x) <- c("vertex_partition", class(x))
  x
}

#' @export
as_vertex_partition.character <- function(x) {
  areas <- sort(unique(x))
  x <- areas %>%
    purrr::map(~ which(x == .x)) %>%
    rlang::set_names(areas)
  class(x) <- c("vertex_partition", class(x))
  x
}

#' @export
as_vertex_partition.integer <- function(x) {
  x <- paste0("P", x)
  as_vertex_partition(x)
}

#' Sigma-Algebra generated by a Partition
#'
#' @param x Input partition stored as a \code{vertex_partition} object.
#'
#' @return Sigma-algebra
#' @export
#'
#' @examples
#' g <- igraph::make_ring(7)
#' m <- as.integer(c(1, 2, 1, 3, 4, 4, 3))
#' p <- as_vertex_partition(m)
#' sa <- generate_sigma_algebra(p)
#' all_full  <- purrr::modify_depth(sa, 2, ~ subgraph_full (g, .x))
#' all_intra <- purrr::modify_depth(sa, 2, ~ subgraph_intra(g, .x))
#' all_inter <- purrr::modify_depth(sa, 2, ~ subgraph_inter(g, .x))
generate_sigma_algebra <- function(x) {
  N <- length(x)
  N:1 %>%
    purrr::map(utils::combn, x = x, simplify = FALSE) %>%
    rlang::set_names(paste0("D", N:1)) %>%
    purrr::map(~ rlang::set_names(
      x = .x,
      nm = .x %>%
        purrr::map(names) %>%
        purrr::map_chr(paste0, collapse = ",")
    ))
}