Venn diagrams

VennDiagrams00.R

# -- | Given the cardinalities of some finite sets, we list all possible
# -- Venn diagrams.
# --
# -- Note: we don't include the empty zone in the tables, because it's always empty.
# --
# -- Remark: if each sets is a singleton set, we get back set partitions:
# --
# -- > > [ length $ enumerateVennDiagrams $ replicate k 1 | k<-[1..8] ]
# -- > [1,2,5,15,52,203,877,4140]
# -- >
# -- > > [ countSetPartitions k | k<-[1..8] ]
# -- > [1,2,5,15,52,203,877,4140]
# --
# -- Maybe this could be called multiset-partitions?
# --
# -- Example:
# --
# -- > autoTabulate RowMajor (Right 6) $ map ascii $ enumerateVennDiagrams [2,3,3]
# --
# enumerateVennDiagrams :: [Int] -> [VennDiagram Int]
# enumerateVennDiagrams dims = 
#   case dims of
#     []     -> []
#     [d]    -> venns1 d
#     (d:ds) -> concatMap (worker (length ds) d) $ enumerateVennDiagrams ds
#   where
# 
#     worker !n !d (VennDiagram table) = result where
# 
#       list   = Map.toList table
#       falses = replicate n False
# 
#       comps k = compositions' (map snd list) k
#       result = 
#         [ unsafeMakeVennDiagram $ 
#             [ (False:tfs    , m-c) | ((tfs,m),c) <- zip list comp ] ++
#             [ (True :tfs    ,   c) | ((tfs,m),c) <- zip list comp ] ++
#             [ (True :falses , d-k) ]
#         | k <- [0..d]
#         , comp <- comps k
#         ]
# 
#     venns1 :: Int -> [VennDiagram Int]
#     venns1 p = [ theVenn ] where 
#       theVenn = unsafeMakeVennDiagram [ ([True],p) ] 
enumerateVennDiagrams <- function(dims) {
  worker <- function(n, d, tbl) {
    falses <- rep(FALSE, n)
    cardinalities <- vapply(tbl, `[[`, integer(1L), 2L)
    do.call(c, lapply(0L:min(d, sum(cardinalities)), function(k) {
      compstns <- partitions::blockparts(cardinalities, k)
      apply(compstns, 2L, function(comp) {
        h <- min(length(comp), length(tbl))
        L1 <- lapply(seq_len(h), function(i) {
          tfs <- tbl[[i]][[1L]]
          m   <- tbl[[i]][[2L]]
          list(c(FALSE, tfs), m - comp[i])
        })  
        L2 <- lapply(seq_len(h), function(i) {
          tfs <- tbl[[i]][[1L]]
          list(c(TRUE, tfs), comp[i])
        })
        L3 <- list(list(c(TRUE, falses), d - k))
        c(L1, L2, L3)
      }, simplify = FALSE)
    }))
  }
  venns1 <- function(p) {
    list(list(list(TRUE, p)))
  }
  dims <- as.integer(dims)
  if(length(dims) == 0L) {
    list()
  } else if(length(dims) == 1L) {
    venns1(dims)
  } else {
    d <- dims[1L]
    ds <- dims[-1L]
    diagrams <- enumerateVennDiagrams(ds)
    do.call(c, lapply(diagrams, function(diagram) {
      worker(length(ds), d, diagram)
    }))
  }
}

allVennDiagrams <- function(cardinalities, output = "dataframes") {
  output <- match.arg(output, c("dataframes", "lists"))
  diagrams <- enumerateVennDiagrams(cardinalities)
  if(output == "dataframes") {
    lapply(diagrams, function(diagram) {
      booleanM <- t(vapply(diagram, `[[`, logical(length(dims)), 1L))
      colnames(booleanM) <- LETTERS[seq_along(dims)]
      cbind(
        as.data.frame(booleanM),
        "card" = vapply(diagram, `[[`, integer(1L), 2L)
      )
    })
  } else {
    diagrams
  }
}
  
dims <- c(3, 2)
diagrams <- allVennDiagrams(dims)

dg <- diagrams[[3]]
x <- data.frame(
  A = c(TRUE, TRUE, TRUE),
  B = c(TRUE, TRUE, FALSE)
)
venn(x, ilabels = "counts")

library(ggVennDiagram)
shd <- get_shape_data(2)
id <- shd$regionLabel$id

diagrams <- allVennDiagrams(c(3, 2), output = "lists")
diagram <- diagrams[[1L]]

library(ggVennDiagram)
nsets <- 2
shd <- get_shape_data(nsets)
id <- shd$regionLabel$id
sets <- LETTERS[1L:nsets]

l <- length(diagram)
newDiagram <- integer(l)
ids <- nms <- character(l)
for(i in seq_len(l)) {
  bools <- diagram[[i]][[1L]]
  ids[i] <- paste0((1L:nsets)[bools], collapse = "/")
  nms[i] <- paste0(sets[bools], collapse = "/")
  newDiagram[i] <- diagram[[i]][[2L]]
}
names(newDiagram) <- ids

library(tibble)
shd$regionData <- tibble(id = ids, count = newDiagram[ids], name = nms)
shd$regionLabel$count <- newDiagram[id]
shd$regionLabel$name <- nms
shd$setLabel$name <- sets

plot_venn(shd)

library(ggVennDiagram)
library(tibble)
#' @title Compute data for plotting a Venn diagram
#' @description Compute data for usage in \code{\link[ggVennDiagram]{plot_venn}}.
#' 
#' @param diagram a Venn diagram as one returned by \code{\link{allVennDiagrams}}
#' @param type argument passed to \code{\link[ggVennDiagram]{get_shape_data}}
#' 
#' @returns A tibble.
#' @export
#' @importFrom ggVennDiagram get_shape_data
#' @importFrom tibble tibble
vennData <- function(diagram, type = NULL) {
  if(inherits(diagram, "data.frame")) {
    diagram2 <- vector("list", nrow(diagram))
    n <- ncol(diagram)
    ind <- seq_len(n - 1L)
    for(i in seq_along(diagram2)) {
      diagram2[[i]] <- list(unlist(diagram[i, ind]), diagram[i, n])
    }
    diagram <- diagram2
  }
  nsets <- length(diagram[[1L]][[1L]])
  shd <- get_shape_data(nsets, type = type)
  sets <- LETTERS[1L:nsets]
  l <- length(diagram)
  newDiagram <- integer(l)
  ids <- nms <- character(l)
  for(i in seq_len(l)) {
    zone <- diagram[[i]]
    bools <- zone[[1L]]
    ids[i] <- paste0((1L:nsets)[bools], collapse = "/")
    nms[i] <- paste0(sets[bools], collapse = "/")
    newDiagram[i] <- zone[[2L]]
  }
  names(newDiagram) <- ids
  shd$regionData <- tibble(id = ids, count = newDiagram[ids], name = nms)
  shd$regionLabel$count <- newDiagram[shd$regionLabel$id]
  shd$regionLabel$name <- nms
  shd$setLabel$name <- sets
  shd
}

VennDiagrams01.R

library(partitions)

#' @importFrom partitions blockparts
#' @noRd
enumerateVennDiagrams <- function(dims) {
  worker <- function(n, d, tbl) {
    falses <- rep(FALSE, n)
    cardinalities <- vapply(tbl, `[[`, integer(1L), 2L)
    do.call(c, lapply(0L:min(d, sum(cardinalities)), function(k) {
      compstns <- blockparts(cardinalities, k)
      apply(compstns, 2L, function(comp) {
        h <- min(length(comp), length(tbl))
        L1 <- lapply(seq_len(h), function(i) {
          tfs <- tbl[[i]][[1L]]
          m   <- tbl[[i]][[2L]]
          list(c(FALSE, tfs), m - comp[i])
        })  
        L2 <- lapply(seq_len(h), function(i) {
          tfs <- tbl[[i]][[1L]]
          list(c(TRUE, tfs), comp[i])
        })
        L3 <- list(list(c(TRUE, falses), d - k))
        c(L1, L2, L3)
      }, simplify = FALSE)
    }))
  }
  venns1 <- function(p) {
    list(list(list(TRUE, p)))
  }
  dims <- as.integer(dims)
  if(length(dims) == 0L) {
    list()
  } else if(length(dims) == 1L) {
    venns1(dims)
  } else {
    d <- dims[1L]
    ds <- dims[-1L]
    diagrams <- enumerateVennDiagrams(ds)
    do.call(c, lapply(diagrams, function(diagram) {
      worker(length(ds), d, diagram)
    }))
  }
}

#' @title Enumeration of Venn diagrams
#' @description Given the cardinalities of some sets, returns all possible 
#'   Venn diagrams of these sets.
#' 
#' @param cardinalities vector of positive integers
#' @param output either \code{"lists"} or \code{"dataframes"}
#' 
#' @returns List of Venn diagrams.
#' @export
allVennDiagrams <- function(cardinalities, output = "dataframes") {
  output <- match.arg(output, c("dataframes", "lists"))
  diagrams <- enumerateVennDiagrams(cardinalities)
  if(output == "dataframes") {
    lapply(diagrams, function(diagram) {
      booleanM <- t(vapply(diagram, `[[`, logical(length(dims)), 1L))
      colnames(booleanM) <- LETTERS[seq_along(dims)]
      cbind(
        as.data.frame(booleanM),
        "card" = vapply(diagram, `[[`, integer(1L), 2L)
      )
    })
  } else {
    diagrams
  }
}
  
diagrams <- allVennDiagrams(c(3, 2))
diagram <- diagrams[[1L]]


library(ggVennDiagram)
library(tibble)
#' @title Compute data for plotting a Venn diagram
#' @description Compute data for usage in \code{\link[ggVennDiagram]{plot_venn}}.
#' 
#' @param diagram a Venn diagram as one returned by \code{\link{allVennDiagrams}}
#' @param type argument passed to \code{\link[ggVennDiagram]{get_shape_data}}
#' 
#' @returns A tibble.
#' @export
#' @importFrom ggVennDiagram get_shape_data
#' @importFrom tibble tibble
vennData <- function(diagram, type = NULL) {
  if(inherits(diagram, "data.frame")) {
    diagram2 <- vector("list", nrow(diagram))
    n <- ncol(diagram)
    ind <- seq_len(n - 1L)
    for(i in seq_along(diagram2)) {
      diagram2[[i]] <- list(unlist(diagram[i, ind]), diagram[i, n])
    }
    diagram <- diagram2
  }
  nsets <- length(diagram[[1L]][[1L]])
  shd <- get_shape_data(nsets, type = type)
  sets <- LETTERS[1L:nsets]
  l <- length(diagram)
  newDiagram <- integer(l)
  ids <- nms <- character(l)
  for(i in seq_len(l)) {
    zone <- diagram[[i]]
    bools <- zone[[1L]]
    ids[i] <- paste0((1L:nsets)[bools], collapse = "/")
    nms[i] <- paste0(sets[bools], collapse = "/")
    newDiagram[i] <- zone[[2L]]
  }
  names(newDiagram) <- ids
  shd$regionData <- tibble(id = ids, count = newDiagram[ids], name = nms)
  shd$regionLabel$count <- newDiagram[shd$regionLabel$id]
  shd$regionLabel$name <- nms
  shd$setLabel$name <- sets
  shd
}