R/venn.R

In venn: Draw Venn Diagrams

# Copyright (c) 2022, Adrian Dusa
# All rights reserved.
# 
# Redistribution and use in source and binary forms, with or without
# modification, in whole or in part, are permitted provided that the
# following conditions are met:
#     * Redistributions of source code must retain the above copyright
#       notice, this list of conditions and the following disclaimer.
#     * Redistributions in binary form must reproduce the above copyright
#       notice, this list of conditions and the following disclaimer in the
#       documentation and/or other materials provided with the distribution.
#     * The names of its contributors may NOT be used to endorse or promote products
#       derived from this software without specific prior written permission.
# 
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
# WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
# DISCLAIMED. IN NO EVENT SHALL ADRIAN DUSA BE LIABLE FOR ANY
# DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
# (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
# LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
# ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

`venn` <-
function(x, snames = "", counts = NULL, ilabels = FALSE, ellipse = FALSE,
    zcolor = "bw", opacity = 0.3, plotsize = 15, ilcs = 0.6, sncs = 0.85,
    borders = TRUE, box = TRUE, par = TRUE, ggplot = FALSE, ...) {
    if (missing(x)) {
        admisc::stopError("Argument <x> is missing.")
    }
    if (ggplot) {
        ilcs <- ilcs * 2.5 / 0.6
        sncs <- sncs * 3.5 / 0.85
        if (
            !requireNamespace("ggplot2", quietly = TRUE) |
            !requireNamespace("ggpolypath", quietly = TRUE)
        ) {
            admisc::stopError(
                paste(
                    "Packages \"ggplot2\" and \"ggpolypath\" are needed",
                    "to make this work, please install."
                )
            )
        }
    }
    funargs <- unlist(lapply(match.call(), deparse)[-1])
    if (!is.element("cexil", names(funargs))) {
        names(funargs)[which(names(funargs) == "cexil")] <- "ilcs"
    }
    if (!is.element("cexsn", names(funargs))) {
        names(funargs)[which(names(funargs) == "cexsn")] <- "sncs"
    }
    if (inherits(tryCatch(eval(x), error = function(e) e), "error")) {
        x <- funargs["x"]
    }
    if (is.numeric(x)) {
        if (length(x) > 1) {
            admisc::stopError(
                "Argument <x> can be a single digit, for up to 7 sets."
            )
        }
    }
    if (!identical(zcolor, "bw") & !identical(zcolor, "style")) {
        zcolor <- admisc::splitstr(zcolor)
        testcolor <- tryCatch(col2rgb(zcolor), error = function(e) e)
        if (!is.matrix(testcolor)) {
            admisc::stopError("Invalid color(s) in argument <zcolor>.")
        }
    }
    nofsets <- 0
    if (!identical(snames, "")) {
        if (!is.character(snames)) {
            admisc::stopError("The argument <snames> should be character.")
        }
        if (length(snames) == 1) snames <- admisc::splitstr(snames)
        nofsets <- length(snames)
    }
    ttqca <- FALSE
    listx <- FALSE
    cts <- NULL
    if (is.null(counts)) {
        counts <- FALSE
    }
    else if (is.numeric(counts)) {
        if (is.numeric(x)) {
            if (length(counts) == 2^x) {
                cts <- counts
                counts <- TRUE
            }
            else {
                counts <- FALSE
            }
        }
        else {
            counts <- FALSE
        }
    }
    if (any(is.element(c("qca", "QCA_min", "tt", "QCA_tt"), class(x)))) {
        ttqca <- TRUE
        otype <- "input"
        if (any(is.element(c("tt", "QCA_tt"), class(x)))) {
            QCA <- all(
                which(
                    is.element(
                        c("minmat", "DCC", "options", "neg.out", "opts"),
                        names(x)
                    )
                ) < 4
            )
            otype <- "truth table"
            tt <- x$tt
            snames <- unlist(
                strsplit(
                    gsub("[[:space:]]", "", x$options$conditions),
                    split = ","
                )
            )
            noflevels <- x$noflevels
        }
        else {
            QCA <- all(
                which(
                    is.element(
                        c("minmat", "DCC", "options", "neg.out", "opts"),
                        names(x$tt)
                    )
                ) < 4
            )
            otype <- "minimization"
            oq <- TRUE
            tt <- x$tt$tt
            snames <- unlist(
                strsplit(
                    gsub("[[:space:]]", "", x$tt$options$conditions),
                    split = ","
                )
            )
            noflevels <- x$tt$noflevels
        }
        if (!QCA) {
            admisc::stopError(
                sprintf(
                    "Please create a proper %s object with package QCA.",
                    otype
                )
            )
        }
        if (any(noflevels != 2)) {
            admisc::stopError(
                "Venn diagrams are not possible for multivalue data."
            )
        }
        if (nofsets == 0) {
            nofsets <- length(snames)
        }
        if (nofsets < 4 | nofsets > 5) {
            ellipse <- FALSE
        }
        ttcolors <- c(
            "0" = "#ffd885",
            "1" = "#96bc72",
            "C" = "#1c8ac9",
            "?" = "#ffffff" # white
        )
        if (identical(zcolor, "style")) {
            zcolor <- "bw"
        }
        else if (!identical(zcolor, "bw")) {
            if (is.character(zcolor) & length(zcolor) >= 3) {
                ttcolors[c("0", "1", "C")] <- zcolor[1:3]
            }
        }
        individual <- length(opacity) == nrow(tt)
        gvenn <- openPlot(plotsize, par = par, ggplot = ggplot, ... = ...)
        if (individual) {
            for (i in seq(nrow(tt))) {
                if (tt$OUT[i] != "?") {
                    color <- adjustcolor(
                        ttcolors[tt$OUT[i]],
                        alpha.f = as.numeric(opacity[i])
                    )
                    if (i == 1) {
                        zeroset <- matrix(
                            c(0, 1000, 1000, 0, 0, 0, 0, 1000, 1000, 0),
                            ncol = 2
                        )
                        colnames(zeroset) <- c("x", "y")
                        polygons <- rbind(
                            zeroset,
                            rep(NA, 2),
                            getZones(0, nofsets, ellipse)[[1]]
                        )
                        polygons <- polygons[-nrow(polygons), ]
                        if (is.null(gvenn)) {
                            polypath(
                                polygons,
                                rule = "evenodd",
                                col = color,
                                border = NA
                            )
                        }
                        else {
                            gvenn <- gvenn + ggpolypath::geom_polypath(
                                polygons,
                                rule = "evenodd",
                                col = color
                            )
                        }
                    }
                    else {
                        plotdata <- ints[
                            ints$s == nofsets &
                            ints$v == as.numeric(ellipse) &
                            ints$i == i,
                            c("x", "y")
                        ]
                        if (is.null(gvenn)) {
                            polygon(plotdata, col = color)
                        }
                        else {
                            gvenn <- gvenn + ggplot2::geom_polygon(
                                data = plotdata,
                                ggplot2::aes(x, y),
                                fill = color
                            )
                        }
                    }
                }
            }
        }
        else {
            for (i in names(ttcolors)[1:3]) {
                zones <- as.numeric(rownames(tt[tt$OUT == i, ]))
                if (length(zones) > 0) {
                    if (any(zones == 1)) {
                        zeroset <- matrix(
                            c(0, 1000, 1000, 0, 0, 0, 0, 1000, 1000, 0),
                            ncol = 2
                        )
                        colnames(zeroset) <- c("x", "y")
                        polygons <- rbind(
                            zeroset,
                            rep(NA, 2),
                            getZones(0, nofsets, ellipse)[[1]]
                        )
                        polygons <- polygons[-nrow(polygons), ]
                        if (is.null(gvenn)) {
                            polypath(
                                polygons,
                                rule = "evenodd",
                                col = ttcolors[i],
                                border = NA
                            )
                        }
                        else {
                            gvenn <- gvenn + ggpolypath::geom_polypath(
                                polygons,
                                rule = "evenodd",
                                col = ttcolors[i]
                            )
                        }
                        zones <- zones[-1]
                    }
                    plotdata <- ints[
                        ints$s == nofsets & ints$v == as.numeric(ellipse) &
                        is.element(ints$i, zones),
                        c("x", "y")
                    ]
                    if (is.null(gvenn)) {
                        polygon(plotdata, col = ttcolors[i])
                    }
                    else {
                        gvenn <- gvenn + ggplot2::geom_polygon(
                            data = plotdata,
                            ggplot2::aes(x, y),
                        fill = ttcolors[i]
                            )
                    }
                }
            }
        }
        cts <- tt$n
        x <- nofsets
    }
    else if (is.numeric(x)) {
        nofsets <- x
        if (!identical(snames, "")) {
            if (length(snames) != nofsets) {
                admisc::stopError(
                    "Number of sets not equal with the number of set names."
                )
            }
        }
    }
    else if (is.character(x)) {
        if (any(grepl("\\$solution", funargs["x"]))) {
            obj <- get(unlist(strsplit(funargs["x"], split = "[$]"))[1])
            snames <- obj$tt$options$conditions
            nofsets <- length(snames)
        }
        x <- unlist(strsplit(gsub("[[:space:]]", "", x), split = ","))
        if (all(grepl("[A-Za-z]", x))) { 
            if (identical(snames, "")) {
                y <- admisc::translate(
                    paste(x, collapse = "+"),
                    snames = snames
                )
                snames <- colnames(y)
                nofsets <- length(snames)
            }
            x <- lapply(x, function(x) {
                return(paste(apply(
                    admisc::translate(x, snames = snames),
                    1,
                    function(x) {
                        x[x < 0] <- "-"
                        return(paste(x, collapse = ""))
                    }),
                    collapse = "+"
                ))
            })
        }
        if (!is.list(x)) {
            if (!all(gsub("0|1|-|\\+", "", x) == "")) {
                admisc::stopError("Invalid codes in the rule(s).")
            }
            if (nofsets == 0) {
                nofsets <- unique(nchar(unlist(strsplit(x, split = "\\+"))))
            }
            x <- as.list(x)
        }
    }
    else if (is.data.frame(x)) {
        if (!is.null(names(x))) {
            if (all(names(x) != "")) {
                snames <- names(x)
            }
        }
        if (!all(is.element(unique(unlist(x)), c(0, 1)))) {
            admisc::stopError(
                "As a dataframe, argument <x> can only contain values 0 and 1."
            )
        }
        if (nofsets == 0) {
            nofsets <- length(x)
        }
            cts <- apply(
                sapply(
                    rev(seq(nofsets)),
                    function(x) {
                        rep.int(
                            c(sapply(0:1, function(y) rep.int(y, 2^(x - 1)))),
                            2^nofsets / 2^x
                        )
                    }
                ),
                1,
                function(l1) {
                    sum(apply(x, 1, function(l2) {
                        all(l1 == l2)
                    }))
                }
            )
        counts <- TRUE
        x <- nofsets
    }
    else if (is.list(x)) {
        if (any(grepl("\\$solution", funargs["x"]))) {
            obj <- get(
                unlist(
                    strsplit(funargs["x"], split = "[$]")
                )[1]
            )
            snames <- obj$tt$options$conditions
            nofsets <- length(snames)
            x <- admisc::translate(
                paste(unlist(x), collapse = " + "),
                snames = snames
            )
            x <- as.list(apply(x, 1, function(y) {
                y[y < 0] <- "-"
                return(paste(y, collapse = ""))
            }))
        }
        else {
            listx <- TRUE
            if (length(x) > 7) {
                x <- x[seq(7)]
            }
            if (!is.null(names(x))) {
                if (all(names(x) != "")) {
                    snames <- names(x)
                }
            }
            if (identical(snames, "")) {
                snames <- LETTERS[seq(length(x))]
            }
            if (nofsets == 0) {
                nofsets <- length(x)
            }
            tt <- sapply(
                rev(seq(nofsets)),
                function(x) {
                    rep.int(
                        c(sapply(0:1, function(y) rep.int(y, 2^(x - 1)))),
                        2^nofsets / 2^x
                    )
                }
            )
            colnames(tt) <- snames
            intersections <- apply(tt, 1,
                function(y) {
                    setdiff(Reduce(intersect, x[y == 1]), unlist(x[y == 0]))
                }
            )
            names(intersections) <- apply(
                tt,
                1,
                function(x) paste(snames[x == 1], collapse = ":")
            )
            cts <- unlist(lapply(intersections, length))
            intersections <- intersections[cts > 0]
            tt <- as.data.frame(cbind(tt, counts = cts))
            attr(tt, "intersections") <- intersections
            counts <- TRUE
            x <- nofsets
        }
    }
    else {
        admisc::stopError("Unrecognised argument <x>.")
    }
    if (nofsets > 7) {
        admisc::stopError("Venn diagrams can be drawn up to 7 sets.")
    }
    else if (nofsets < 4 | nofsets > 5) {
        ellipse <- FALSE
    }
    if (identical(snames, "")) {
        snames <- LETTERS[seq(nofsets)]
    }
    else {
        if (length(snames) != nofsets) {
            admisc::stopError(
                "Length of set names does not match the number of sets."
            )
        }
    }
    if (!is.element("ilcs", names(funargs))) {
        if (!ggplot) {
            ilcs <- ilcs - ifelse(nofsets > 5, 0.1, 0) - ifelse(nofsets > 6, 0.05, 0)
        }
    }
    if (!ttqca) {
        gvenn <- openPlot(plotsize, par = par, ggplot = ggplot, ... = ...)
    }
    gvenn <- plotRules(
        x, zcolor, ellipse, opacity, allborders = borders, box = box,
        gvenn = gvenn, ... = ...
    )
    if (ilabels | counts & !is.null(cts)) {
        ilabels <- icoords$l[
            icoords$s == nofsets & icoords$v == as.numeric(ellipse)
        ]
        if (counts) {
            cts[cts == 0] <- ""
            ilabels <- cts
        }
        icoords <- icoords[
            icoords$s == nofsets & icoords$v == as.numeric(ellipse),
            c("x", "y")
        ]
        if (ggplot) {
            for (i in which(ilabels != "")) {
                gvenn <- gvenn + ggplot2::annotate("text",
                    x = icoords$x[i], y = icoords$y[i],
                    label = ilabels[i],
                    size = ilcs
                )
            }
        }
        else {
            text(icoords, labels = ilabels, cex = ilcs)
        }
    }
    scoords <- scoords[
        scoords$s == nofsets & scoords$v == as.numeric(ellipse),
        c("x", "y")
    ]
    if (ggplot) {
        for (i in seq(length(snames))) {
            gvenn <- gvenn + ggplot2::annotate("text",
                x = scoords$x[i], y = scoords$y[i],
                label = snames[i],
                size = sncs
            )
        }
    }
    else {
        text(scoords, labels = snames, cex = sncs)
    }
    if (ttqca) {
        if (is.null(gvenn)) {
            points(
                seq(10, 340, length.out = 4),
                rep(-25, 4),
                pch = 22,
                bg = ttcolors,
                cex = 1.75
            )
            text(
                seq(40, 370, length.out = 4),
                rep(-26, 4),
                names(ttcolors),
                cex = 0.85
            )
        }
        else {
            gvenn <- gvenn +
            ggplot2::annotate("rect",
                xmin = 10, xmax = 32, ymin = -44, ymax = -22,
                fill = ttcolors[1],
                col = "black"
            ) + 
            ggplot2::annotate("rect",
                xmin = 120, xmax = 142, ymin = -44, ymax = -22,
                fill = ttcolors[2],
                col = "black"
            ) + 
            ggplot2::annotate("rect",
                xmin = 230, xmax = 252, ymin = -44, ymax = -22,
                fill = ttcolors[3],
                col = "black"
            ) + 
            ggplot2::annotate("rect",
                xmin = 340, xmax = 362, ymin = -44, ymax = -22,
                fill = ttcolors[4],
                col = "black"
            ) +
            ggplot2::annotate("text",
                x = 50, y = -34,
                label = names(ttcolors)[1]
            ) +
            ggplot2::annotate("text",
                x = 160, y = -34,
                label = names(ttcolors)[2]
            ) +
            ggplot2::annotate("text",
                x = 270, y = -34,
                label = names(ttcolors)[3]
            ) +
            ggplot2::annotate("text",
                x = 380, y = -34,
                label = names(ttcolors)[4]
            )
        }
    }
    if (ggplot) {
        return(gvenn)
    }
    if (listx) {
        return(invisible(tt))
    }
}