Nothing
R/venn.R
In venn: Draw Venn Diagrams
Defines functions
`venn`
# Copyright (c) 2016 - 2024, 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 enclosed data must cite this package according to
# the citation("venn") command specific to this R package, along with the
# appropriate weblink to the CRAN package "venn".
# * Redistributions of enclosed data in other R packages must list package
# "venn" as a hard dependency in the Imports: field.
# * 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 = "", ilabels = NULL, 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.")
}
dots <- list(...)
counts <- dots$counts
cts <- NULL
tjqca <- is.element("trajectory", names(dots))
trajectory <- dots$trajectory
tjcases <- names(trajectory)
dots$trajectory <- NULL
if (!is.null(ilabels)) {
if (identical(ilabels, "counts")) {
counts <- TRUE
ilabels <- NULL
}
else {
if (isTRUE(ilabels)) {
counts <- NULL
}
else {
if (is.atomic(ilabels) && !is.logical(ilabels)) {
cts <- ilabels
counts <- NULL
ilabels <- NULL
}
}
}
}
if (is.null(counts)) {
counts <- FALSE
}
else {
if (is.atomic(counts) && !is.logical(counts)) {
cts <- counts
counts <- TRUE
}
counts <- isTRUE(counts)
}
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
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
rnms <- rownames(x$initial.data)
ttcases <- x$tt$cases
}
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
rnms <- rownames(x$tt$initial.data)
ttcases <- x$tt$tt$cases
}
if (tjqca) {
if (!identical(
sort(tjcases),
sort(unique(gsub("[0-9]", "", rnms)))
)) {
admisc::stopError("Case names do not match the truth table.")
}
}
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 > 7) {
admisc::stopError(
"Venn diagrams can only be drawn up to 7 explanatory conditions."
)
}
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 <- do.call(
openPlot,
c(
list(plotsize, par = par, ggplot = ggplot),
dots
)
)
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]
)
}
}
}
}
if (isTRUE(counts) & is.null(cts)) {
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)
}
if (isTRUE(counts) & is.null(cts)) {
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)
}))
}
)
}
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 = ":")
)
ttcts <- unlist(lapply(intersections, length))
intersections <- intersections[ttcts > 0]
tt <- as.data.frame(cbind(tt, counts = ttcts))
attr(tt, "intersections") <- intersections
if (isTRUE(counts) & is.null(cts)) {
cts <- ttcts
}
x <- nofsets
}
}
else {
admisc::stopError("Unrecognised argument <x>.")
}
if (length(cts) != 2^nofsets) {
cts <- NULL
counts <- NULL
}
if (nofsets > 7) {
admisc::stopError("Venn diagrams can only 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 (isTRUE(ilabels) | !is.null(cts) | tjqca) {
if (isTRUE(ilabels)) {
ilabels <- icoords$l[
icoords$s == nofsets & icoords$v == as.numeric(ellipse)
]
} else if (!is.null(cts)) {
if (isTRUE(counts)) {
cts[cts == 0] <- ""
}
ilabels <- cts
}
icoords <- icoords[
icoords$s == nofsets & icoords$v == as.numeric(ellipse),
c("x", "y")
]
if (!is.null(ilabels)) {
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)
}
}
if (tjqca) {
ttcases <- strsplit(gsub(";", ",", ttcases), split = ",")
caselist <- lapply(tjcases, function(x) {
rnms <- rnms[is.element(gsub("[0-9]", "", rnms), x)]
rnmsindex <- c()
for (i in seq(length(rnms))) {
rnmsindex <- c(
rnmsindex,
which(sapply(ttcases, function(x) {
any(x == rnms[i])
}))
)
}
return(rle(rnmsindex))
})
for (case in seq(length(tjcases))) {
rlecase <- caselist[[case]]
lengths <- rlecase$lengths
values <- rlecase$values
uvalues <- unique(values)
jx <- jitter(icoords$x[uvalues], factor = 2)
jy <- jitter(icoords$y[uvalues], factor = 2)
x <- jx[match(values, uvalues)]
y <- jy[match(values, uvalues)]
tcase <- trajectory[[tjcases[case]]]
if (is.null(tcase$length)) {
tcase$length <- 0.12
}
if (is.null(tcase$lwd)) {
tcase$lwd <- 2
}
if (is.null(tcase$col)) {
tcase$col <- "black"
}
if (length(values) == 1) {
points(
x,
y,
pch = ifelse(is.null(tcase$pch), 20, tcase$pch),
cex = ifelse(is.null(tcase$cex), 2, tcase$cex),
col = tcase$col
)
}
else {
i <- 1
j <- 2
while (i <= length(values) - 1) {
if (i == 1 & lengths[1] > 1) {
points(
x[1],
y[1],
pch = ifelse(is.null(tcase$pch), 20, tcase$pch),
cex = ifelse(is.null(tcase$cex), 1.5, tcase$cex),
col = tcase$col
)
}
back <- FALSE
while (j <= length(values)) {
if (j < length(values)) {
back <- values[j + 1] == values[i]
}
callist <- c(
list(x[i], y[i], x[j], y[j]),
tcase
)
callist$code <- 2
do.call(graphics::arrows, callist)
j <- j + 1 + back
}
i <- i + 1 + back
}
}
}
}
}
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))
}
}
Try the venn package in your browser
Any scripts or data that you put into this service are public.
venn documentation built on May 29, 2024, 1:18 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions `venn`
# Copyright (c) 2016 - 2024, 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 enclosed data must cite this package according to
# the citation("venn") command specific to this R package, along with the
# appropriate weblink to the CRAN package "venn".
# * Redistributions of enclosed data in other R packages must list package
# "venn" as a hard dependency in the Imports: field.
# * 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 = "", ilabels = NULL, 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.")
}
dots <- list(...)
counts <- dots$counts
cts <- NULL
tjqca <- is.element("trajectory", names(dots))
trajectory <- dots$trajectory
tjcases <- names(trajectory)
dots$trajectory <- NULL
if (!is.null(ilabels)) {
if (identical(ilabels, "counts")) {
counts <- TRUE
ilabels <- NULL
}
else {
if (isTRUE(ilabels)) {
counts <- NULL
}
else {
if (is.atomic(ilabels) && !is.logical(ilabels)) {
cts <- ilabels
counts <- NULL
ilabels <- NULL
}
}
}
}
if (is.null(counts)) {
counts <- FALSE
}
else {
if (is.atomic(counts) && !is.logical(counts)) {
cts <- counts
counts <- TRUE
}
counts <- isTRUE(counts)
}
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
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
rnms <- rownames(x$initial.data)
ttcases <- x$tt$cases
}
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
rnms <- rownames(x$tt$initial.data)
ttcases <- x$tt$tt$cases
}
if (tjqca) {
if (!identical(
sort(tjcases),
sort(unique(gsub("[0-9]", "", rnms)))
)) {
admisc::stopError("Case names do not match the truth table.")
}
}
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 > 7) {
admisc::stopError(
"Venn diagrams can only be drawn up to 7 explanatory conditions."
)
}
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 <- do.call(
openPlot,
c(
list(plotsize, par = par, ggplot = ggplot),
dots
)
)
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]
)
}
}
}
}
if (isTRUE(counts) & is.null(cts)) {
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)
}
if (isTRUE(counts) & is.null(cts)) {
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)
}))
}
)
}
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 = ":")
)
ttcts <- unlist(lapply(intersections, length))
intersections <- intersections[ttcts > 0]
tt <- as.data.frame(cbind(tt, counts = ttcts))
attr(tt, "intersections") <- intersections
if (isTRUE(counts) & is.null(cts)) {
cts <- ttcts
}
x <- nofsets
}
}
else {
admisc::stopError("Unrecognised argument <x>.")
}
if (length(cts) != 2^nofsets) {
cts <- NULL
counts <- NULL
}
if (nofsets > 7) {
admisc::stopError("Venn diagrams can only 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 (isTRUE(ilabels) | !is.null(cts) | tjqca) {
if (isTRUE(ilabels)) {
ilabels <- icoords$l[
icoords$s == nofsets & icoords$v == as.numeric(ellipse)
]
} else if (!is.null(cts)) {
if (isTRUE(counts)) {
cts[cts == 0] <- ""
}
ilabels <- cts
}
icoords <- icoords[
icoords$s == nofsets & icoords$v == as.numeric(ellipse),
c("x", "y")
]
if (!is.null(ilabels)) {
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)
}
}
if (tjqca) {
ttcases <- strsplit(gsub(";", ",", ttcases), split = ",")
caselist <- lapply(tjcases, function(x) {
rnms <- rnms[is.element(gsub("[0-9]", "", rnms), x)]
rnmsindex <- c()
for (i in seq(length(rnms))) {
rnmsindex <- c(
rnmsindex,
which(sapply(ttcases, function(x) {
any(x == rnms[i])
}))
)
}
return(rle(rnmsindex))
})
for (case in seq(length(tjcases))) {
rlecase <- caselist[[case]]
lengths <- rlecase$lengths
values <- rlecase$values
uvalues <- unique(values)
jx <- jitter(icoords$x[uvalues], factor = 2)
jy <- jitter(icoords$y[uvalues], factor = 2)
x <- jx[match(values, uvalues)]
y <- jy[match(values, uvalues)]
tcase <- trajectory[[tjcases[case]]]
if (is.null(tcase$length)) {
tcase$length <- 0.12
}
if (is.null(tcase$lwd)) {
tcase$lwd <- 2
}
if (is.null(tcase$col)) {
tcase$col <- "black"
}
if (length(values) == 1) {
points(
x,
y,
pch = ifelse(is.null(tcase$pch), 20, tcase$pch),
cex = ifelse(is.null(tcase$cex), 2, tcase$cex),
col = tcase$col
)
}
else {
i <- 1
j <- 2
while (i <= length(values) - 1) {
if (i == 1 & lengths[1] > 1) {
points(
x[1],
y[1],
pch = ifelse(is.null(tcase$pch), 20, tcase$pch),
cex = ifelse(is.null(tcase$cex), 1.5, tcase$cex),
col = tcase$col
)
}
back <- FALSE
while (j <= length(values)) {
if (j < length(values)) {
back <- values[j + 1] == values[i]
}
callist <- c(
list(x[i], y[i], x[j], y[j]),
tcase
)
callist$code <- 2
do.call(graphics::arrows, callist)
j <- j + 1 + back
}
i <- i + 1 + back
}
}
}
}
}
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))
}
}
Try the venn package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.