r-gregmisc-users Mailing List for R gregmisc package (Page 30)

SourceForge Headquarters 225 Broadway Suite 1600 San Diego, CA 92101 +1 (858) 422-6466

Revision: 1271
          http://r-gregmisc.svn.sourceforge.net/r-gregmisc/?rev=1271&view=rev
Author:   warnes
Date:     2008-05-19 17:14:51 -0700 (Mon, 19 May 2008)

Log Message:
-----------
Add Venn Diagram plot submitted by Steffen Moeller

Modified Paths:
--------------
    trunk/gplots/DESCRIPTION
    trunk/gplots/NAMESPACE

Added Paths:
-----------
    trunk/gplots/R/venn.R
    trunk/gplots/man/venn.Rd

Modified: trunk/gplots/DESCRIPTION
===================================================================

--- trunk/gplots/DESCRIPTION	2008-05-13 03:16:08 UTC (rev 1270)
+++ trunk/gplots/DESCRIPTION	2008-05-20 00:14:51 UTC (rev 1271)
@@ -2,10 +2,13 @@
 Title: Various R programming tools for plotting data
 Description: Various R programming tools for plotting data
 Depends: R (>= 1.9.0), gtools, gdata, stats, caTools
-Recommends: datasets
-Suggests: gtools, gdata
-Version: 2.6.0
+Recommends: datasets, grid
+Suggests: gtools, grid
+Version: 2.7.0
 Author: Gregory R. Warnes. Includes R source code and/or documentation
-        contributed by Ben Bolker and Thomas Lumley
+        contributed by (in alphabetical order): 
+ 	  Ben Bolker, Lodewijk Bonebakker, Robert Gentleman, Wolfgang
+ 	  Huber Andy Liaw, Thomas Lumley, Martin Maechler, Arni
+ 	  Magnusson, Steffen Moeller, Marc Schwartz, Bill Venables
 Maintainer: Gregory R. Warnes <wa...@bs...>
 License: GPL-2

Modified: trunk/gplots/NAMESPACE
===================================================================
--- trunk/gplots/NAMESPACE	2008-05-13 03:16:08 UTC (rev 1270)
+++ trunk/gplots/NAMESPACE	2008-05-20 00:14:51 UTC (rev 1271)
@@ -25,6 +25,7 @@
        smartlegend,
        space,
        textplot,
+       venn,
        wapply
 )
 

Added: trunk/gplots/R/venn.R
===================================================================
--- trunk/gplots/R/venn.R	                        (rev 0)
+++ trunk/gplots/R/venn.R	2008-05-20 00:14:51 UTC (rev 1271)
@@ -0,0 +1,437 @@
+# This code plots Venn Diagrams for up to 5 sets. The
+# function getVennCounts is passed a list of vectors.
+# This is transformed into a table indicating the
+# number of members for each intersection. This table
+# is generated for any number of sets.
+
+# The function drawVennDiagram plots circles (up to three
+# sets) or ellipses (4 and 5 sets) to depict the sets.
+# The sum of values placed is the number of entries of
+# each set.
+
+# transform base
+#   v = value of base 10 to be transformed
+#   b = new base
+#   l = minimal length of returned array (default is 1)
+# return value: array of factors, highest exponent first
+baseOf<-function(v,b,l=1) {
+	remainder<-v
+	i<-l
+	ret<-NULL
+	while(remainder>0 || i>0) {
+		#print(paste("i=",i," remainder=",remainder))
+		m<-remainder%%b
+		if (is.null(ret)) {
+			ret<-m
+		}
+		else {
+			ret<-c(m,ret)
+		}
+		remainder <- remainder %/% b
+		i<-i-1
+	}
+	return(ret)
+}
+
+# Function to determine values of a venn diagram
+# It works for an arbitrary large set of input sets.
+#
+
+getVennCounts <- function(l, universe, ...)
+  UseMethod("getVennCounts")
+
+getVennCounts.data.frame <- function(l, universe=NA, ...)
+  {
+    if( !all(unique(unlist(l)) %in% c(0,1))  )
+      stop("Only indicator columns permitted")
+
+    l <- sapply( l, function(x) which(as.logical(x)))
+    getVennCounts.list(l)
+  }
+
+getVennCounts.list<-function(l,universe=NA) {
+	numSets<-length(l)
+	result.table<-NULL
+	result.table.names<-NULL
+	for (i in 0:(-1 + 2^numSets)) {
+		# i2 is a binary representation of that number
+		i2<-baseOf(i,2,numSets)
+
+		# some debug output
+		#print(paste(i,":",paste(i2,collapse="",sep="")))
+
+		# p.pos determines the position in number
+		#       which is also the set that is inspected
+
+		sel<-universe
+
+		# positive selection first
+		for (p.pos in which(1 == i2) ) {
+			current.set<-l[[p.pos]]
+			#print(paste("set ",p.pos,", val=1: ",paste(current.set,collapse=",")))
+			if (is.null(sel)) {
+				#print("Sel is null")
+			} else if (1 == length(sel) && is.na(sel)) {
+				sel<-current.set
+			}
+			else {
+				w<-which(sel %in% current.set)
+				if (length(w)>0) {
+					sel<-sel[w]
+				}
+				else {
+					sel<-NULL
+				}
+			}
+		}
+
+		# something should be in sel now, otherwise 
+		# the number will be 0
+
+		# negative selection
+		for (p.pos in which(0 == i2) ) {
+			if (is.null(sel) || ( 1 == length(sel) && is.na(sel))) {
+				# The complement is not known, hence no checks done
+			}
+			else {
+				current.set<-l[[p.pos]]
+				w<-which( ! sel %in% current.set)
+				#print(paste("set ",p.pos,", val=1: ",paste(current.set,collapse=",")))
+				if (length(w)>0) {
+					sel<-sel[w]
+				}
+				else {
+					sel<-NULL
+				}
+			}
+		}
+		#print(paste("sel:",paste(sel,collapse=",")))
+
+		if(is.null(sel) || (1 == length(sel) && is.na(sel))) {
+			sel<-NULL
+		}
+
+		r<-length(sel)
+		r.name<-paste(i2,collapse="")
+		result.row<-c(r,i2)
+		dim(result.row)<-c(1,length(result.row))
+		rownames(result.row)<-c(r.name)
+		#print(paste("Adding ",r.name))
+		if (is.null(result.table)) {
+			result.table<-result.row
+		}
+		else {
+			result.table<-rbind(result.table,result.row)
+		}
+		#if (is.null(result.table)) {
+		#	result.table<-r
+		#	result.table.names<-r.name
+		#}
+		#else {
+		#	result.table<-c(result.table,r)
+		#	result.table.names<-c(result.table.names,r.name)
+		#}
+	}
+	#names(result.table)<-result.table.names
+	if (is.null(names(l))) {
+		colnames(result.table)<-c("num",LETTERS[1:numSets])
+	}
+	else{
+		colnames(result.table)<-c("num",names(l))
+	}
+	return(result.table)
+}
+
+#print(getVennCounts(list(A,B,C,D)))
+#print(getVennCounts(list(a=A,b=B,c=C,d=D)))
+
+
+## data should be a matrix.
+##   - The first column of the matrix is the
+##     count of the number of objects with the specified pattern.
+##   - The second and subsequent columns contain 0-1 indicators
+##     giving the pattern of group membership
+
+
+drawVennDiagram <-function(data,small=0.7,
+		showSetLogicLabel=FALSE,simplify=FALSE) {
+	numCircles<-NA
+	data.colnames<-NULL
+	data.rownames<-NULL
+	if(is.matrix(data)) {
+		numCircles<-ncol(data)-1
+		data.colnames<-colnames(data)[2:(ncol(data))]
+		# Order is reverted since later indexing starts with
+		# the "lowest bit" and that is expected at the left
+		data.rownames<-rownames(data)
+	}
+	else {
+		cat("Testing only, presuming first argument to specify",
+                    "the number of circles to draw.\n")
+		numCircles<-data
+	}
+
+	m<-(0:(-1+2^numCircles))
+
+	if (! is.matrix(data)) {
+		##cat("prepare randomised data\n")
+		data<-t(sapply(X=m,FUN=function(v){
+			l<-baseOf(v,2,numCircles)
+			#print(l)
+			return(l)
+		}))
+
+		#print(data)
+		
+		#data.names<-apply(data,1,function(X){
+		#	return(paste(X),collapse="")
+		#})
+		for(i in m) {
+			n<-paste(data[i+1,],collapse="")
+			if (is.null(data.rownames)) {
+				data.rownames<-n
+			}
+			else {
+				data.rownames<-c(data.rownames,n)
+			}
+		}
+		#print(data.rownames)
+		data<-cbind(sample(1:100,size=2^numCircles,replace=TRUE),data)
+		#print(data)
+		rownames(data)<-data.rownames
+		data.colnames<-LETTERS[1:numCircles]
+		colnames(data)<-c("num",data.colnames)
+	}
+
+	if ((2 <= numCircles && numCircles <= 3) || (4 == numCircles && simplify)) {
+		##cat("drawing circles\n")
+		# draw circles with radius 1.7 equally distributed
+		# with centers on a circle of radius 1
+
+		degrees<-2*pi/numCircles*(1:numCircles)
+
+		# scaling factor
+		s<-1/8
+
+		x<-sapply(degrees,FUN=sin)*s + 0.5
+		y<-sapply(degrees,FUN=cos)*s + 0.5
+
+
+		if(!require(grid)) {
+			stop("Need access to 'grid' library.")
+		}
+		grid.newpage()
+		grid.circle(x,y,3/12,name="some name")
+
+		##cat("filling data\n")
+
+		distFromZero<-rep(NA,2^numCircles)
+		degrees<-rep(NA,2^numCircles)
+
+		degrees[(2^numCircles)]<-0
+		distFromZero[(2^numCircles)]<-0
+
+		for (i in 0:(numCircles-1)) {
+			distFromZero[2^i+1] <- 4/12
+			degrees[2^i+1] <- 2*pi/numCircles*i
+			d<-degrees[2^i+1]
+
+			#print(data.colnames)
+
+			grid.text(
+				# starting from the lowest bit, hence reading
+				# lables from the right
+				label=data.colnames[numCircles - i],
+				x=sin(d)*5/12+0.5,
+				y=cos(d)*5/12+0.5,
+				rot=0
+			)
+
+		}
+
+		if (4==numCircles) {
+			for (i in 0:(numCircles-1)) {
+				# Current set bit plus the bit left of it and the bit right of it
+				distFromZero[2^i
+						+2^((i+numCircles-1)%%numCircles)
+						+2^((i+1)%%numCircles)+1] <- 2/12
+				degrees[2^i
+						+2^((i+numCircles-1)%%numCircles)
+						+2^((i+1)%%numCircles)+1] <- degrees[2^i+1]
+			}
+		}
+
+				#degrees[2^i+1] + degrees[2^((i+1)%%numCircles)+1])/2
+			
+		if (3 <=numCircles) {
+			for (i in 0:(numCircles-1)) {
+				distFromZero[(2^i+2^((i+1)%%numCircles))+1]<- 3/12
+				if (i == (numCircles-1)) {
+					degrees[(2^i+2^((i+1)%%numCircles))+1] <- (
+						degrees[2^i+1] + 2*pi+ degrees[1+1])/2
+				}
+				else {
+					degrees[(2^i+2^((i+1)%%numCircles))+1] <- (
+						degrees[2^i+1] + degrees[2^((i+1)%%numCircles)+1])/2
+				}
+
+			}
+		}
+
+		for(i in 1:2^numCircles) {
+			n<-paste(baseOf((i-1),2,numCircles),collapse="")
+			v<-data[n,1]
+			d<-degrees[i]
+			if (1 == length(d) && is.na(d)) {
+				if (v>0) warning("Not shown: ",n,"is",v,"\n")
+			}
+			else {
+				l<-distFromZero[i]
+				x<-sin(d)*l+0.5
+				y<-cos(d)*l+0.5
+				#cat("i=",i," x=",x," y=",y," label=",n,"\n")
+				l<-v
+				if (showSetLogicLabel) l<-paste(n,"\n",v,sep="")
+				grid.text(label=l,x=x,y=y,rot=0)
+			}
+		}
+	}
+	else if (4 <= numCircles && numCircles <= 5 && !simplify) {
+
+            grid.newpage()          
+	    # Function to turn and move ellipses
+	    relocate_elp <- function(e, alpha, x, y){
+			phi=(alpha/180)*pi;
+			xr=e[,1]*cos(phi)+e[,2]*sin(phi)
+			yr=-e[,1]*sin(phi)+e[,2]*cos(phi)
+			xr=x+xr;
+			yr=y+yr;
+			return(cbind(xr, yr))
+	    }
+
+	    lab<-function (identifier, data, showLabel=showSetLogicLabel) {
+			r<-data[identifier,1]
+			if (showLabel) {
+				return(paste(identifier,r,sep="\n"))
+			}
+			else {
+				return(r)
+			}
+	    }
+
+	    plot(c(0, 400), c(0, 400), type="n", axes=F, ylab="", xlab="")
+	    if (4 == numCircles) {
+	        elps=cbind(162*cos(seq(0,2*pi,len=1000)), 108*sin(seq(0,2*pi,len=1000)));
+
+		plot(c(0, 400), c(0, 400), type="n", axes=F, ylab="", xlab="");
+		polygon(relocate_elp(elps, 45,130, 170));
+		polygon(relocate_elp(elps, 45,200, 200));
+		polygon(relocate_elp(elps, 135,200, 200));
+		polygon(relocate_elp(elps, 135,270, 170));
+
+		text( 35, 315, data.colnames[1],cex=1.5)
+		text(138, 347, data.colnames[2],cex=1.5)
+		text(262, 347, data.colnames[3],cex=1.5)
+		text(365, 315, data.colnames[4],cex=1.5)
+
+	        elps <- cbind(130*cos(seq(0,2*pi,len=1000)),
+			80*sin(seq(0,2*pi,len=1000)))
+
+		text( 35, 250, lab("1000",data));
+		text(140, 315, lab("0100",data));
+		text(260, 315, lab("0010",data));
+		text(365, 250, lab("0001",data));
+
+		text( 90, 280, lab("1100",data), cex=small) 
+		text( 95, 110,lab("1010",data) ) 
+		text(200,  50, lab("1001",data), cex=small) 
+		text(200, 290, lab("0110",data)) 
+		text(300, 110, lab("0101",data)) 
+		text(310, 280, lab("0011",data), cex=small) 
+
+		text(130, 230, lab("1110",data))
+		text(245,  75, lab("1101",data),cex=small) 
+		text(155,  75, lab("1011",data),cex=small)
+		text(270, 230, lab("0111",data)) 
+
+		text(200,150,lab("1111",data)) 
+	    }
+	    else if (5 == numCircles) {
+
+	        elps <- cbind(150*cos(seq(0,2*pi,len=1000)),
+			60*sin(seq(0,2*pi,len=1000)))
+
+		polygon(relocate_elp(elps, 90,200, 250))
+		polygon(relocate_elp(elps, 162,250, 220))
+		polygon(relocate_elp(elps, 234,250, 150))
+		polygon(relocate_elp(elps, 306,180, 125))
+		polygon(relocate_elp(elps, 378,145, 200))
+
+		text( 50, 280, data.colnames[1],cex=1.5)
+		text(150, 400, data.colnames[2],cex=1.5)
+		text(350, 300, data.colnames[3],cex=1.5)
+		text(350,  20, data.colnames[4],cex=1.5)
+		text( 50,  10, data.colnames[5],cex=1.5)
+
+		text( 61, 228, lab("10000",data));
+		text(194, 329, lab("01000",data));
+		text(321, 245, lab("00100",data));
+		text(290,  81, lab("00010",data));
+		text(132,  69, lab("00001",data));
+
+		text(146, 250, lab("11000",data), cex=small) 
+		text(123, 188, lab("10100",data), cex=small) 
+		text(275, 152, lab("10010",data), cex=small) 
+		text(137, 146, lab("10001",data), cex=small) 
+		text(243, 268, lab("01100",data), cex=small) 
+		text(175, 267, lab("01010",data), cex=small) 
+		text(187, 117, lab("01001",data), cex=small) 
+		text(286, 188, lab("00110",data), cex=small) 
+		text(267, 235, lab("00101",data), cex=small) 
+		text(228, 105, lab("00011",data), cex=small) 
+
+		text(148, 210, lab("11100",data),cex=small)
+		text(159, 253, lab("11010",data),cex=small) 
+		text(171, 141, lab("11001",data),cex=small) 
+		text(281, 175, lab("10110",data),cex=small) 
+		text(143, 163, lab("10101",data),cex=small) 
+		text(252, 145, lab("10011",data),cex=small) 
+		text(205, 255, lab("01110",data),cex=small) 
+		text(254, 243, lab("01101",data),cex=small) 
+		text(211, 118, lab("01011",data),cex=small) 
+		text(267, 211, lab("00111",data),cex=small) 
+
+		text(170, 231,lab("11110",data),cex=small) 
+		text(158, 169,lab("11101",data),cex=small) 
+		text(212, 139,lab("11011",data),cex=small)
+		text(263, 180,lab("10111",data),cex=small) 
+		text(239, 232,lab("01111",data),cex=small)
+		 
+		text(204,190,lab("11111",data))
+	    }
+	}
+	else {
+		stop(paste("The printing of ",numCircles," circles is not yet supported."))
+	}
+
+}
+
+
+venn <- function(data,
+                 universe=NA,
+                 small=0.7,
+                 showSetLogicLabel=FALSE,
+                 simplify=FALSE,
+                 show.plot=TRUE)
+{
+  counts <- getVennCounts(data)
+
+  if(show.plot)
+    drawVennDiagram(data=counts,
+                    small=small,
+                    showSetLogicLabel=showSetLogicLabel,
+                    simplify=simplify
+                    )
+
+  invisible(counts)
+}

Added: trunk/gplots/man/venn.Rd
===================================================================
--- trunk/gplots/man/venn.Rd	                        (rev 0)
+++ trunk/gplots/man/venn.Rd	2008-05-20 00:14:51 UTC (rev 1271)
@@ -0,0 +1,78 @@
+\name{venn}
+\alias{venn}
+\title{Plot a Venn diagram}
+\description{
+Plot Venn diagrams for up to 5 sets
+}
+\usage{
+venn(data, small = 0.7, showSetLogicLabel = FALSE, simplify = FALSE)
+}
+\arguments{
+  \item{data}{data to be plotted (see below)}
+  \item{small}{Character size of group labels}
+  \item{showSetLogicLabel}{Logical flag indicating whether the internal
+    group label should be displayed}
+  \item{simplify}{Logical flag indicating whether unobserved group
+    should be omitted.}
+}
+\details{
+  \code{data} should be either a named list of vectors containing
+  indexes of group members (1, 2, 3,..) , or a data frame containing indicator
+  variables (TRUE, FALSE, TRUE, ..) for group membership.  Group names
+  will be taken from the component vector or column names.  
+}
+\value{
+  A matrix of all possible sets of groups, and the observed numer of
+  items beloinging to each set of groups is returned invisibly.
+  The fist column contains observed counts, subsequent columns contain
+  0-1 indicators of group membership.
+}
+\author{Steffen Moeller \email{ste...@gm...},
+  with cleanup and packaging by Gregory R. Warnes
+  \email{gr...@ra...}.}
+\examples{
+
+##
+## Example using a list of item indexes  belonging to the
+## specified group.
+##
+A<- 1:20
+B<- 1:20
+C<- 2:20
+D<- 3:21
+input<-list(A,B,C,D)
+input
+
+venn(input)
+
+##
+## Example using a data frame of indicator columns
+##
+A<- as.logical(rbinom(100, 1, 0.2))
+B<- as.logical(rbinom(100, 1, 0.7))
+C<- as.logical(rbinom(100, 1, 0.2))
+D<- as.logical(rbinom(100, 1, 0.1))
+input<-data.frame(A,B,C,D)
+venn(input)
+
+
+## Omit un-observed groupings
+tmp <- venn(input, simplify=T)
+
+## show details
+tmp
+
+## Show internal binary group labels
+venn(input, showSetLogicLabel=TRUE)
+
+## Omit un-observed groupings, and show internal binary group labels 
+venn(input, simplify=T, showSetLogicLabel=TRUE)
+
+
+
+
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.




2006	Jan	Feb	Mar (12)	Apr (5)	May (3)	Jun (5)	Jul (2)	Aug (5)	Sep (7)	Oct (15)	Nov (34)	Dec (3)
2007	Jan (3)	Feb (16)	Mar (28)	Apr (5)	May	Jun (5)	Jul (9)	Aug (50)	Sep (29)	Oct (9)	Nov (25)	Dec (7)
2008	Jan (6)	Feb (4)	Mar (5)	Apr (8)	May (26)	Jun (11)	Jul	Aug (2)	Sep	Oct	Nov	Dec (9)
2009	Jan	Feb (1)	Mar	Apr (2)	May (26)	Jun	Jul (10)	Aug (6)	Sep	Oct (7)	Nov (3)	Dec (2)
2010	Jan (45)	Feb (11)	Mar	Apr (1)	May (8)	Jun (7)	Jul (3)	Aug (1)	Sep	Oct (1)	Nov (9)	Dec (1)
2011	Jan (2)	Feb	Mar	Apr (3)	May (1)	Jun	Jul	Aug (14)	Sep (29)	Oct (3)	Nov	Dec (3)
2012	Jan	Feb	Mar	Apr (7)	May (6)	Jun (59)	Jul	Aug (8)	Sep (21)	Oct	Nov	Dec
2013	Jan (1)	Feb	Mar (10)	Apr	May (18)	Jun (25)	Jul (18)	Aug (1)	Sep (6)	Oct (28)	Nov (4)	Dec (13)
2014	Jan (7)	Feb (5)	Mar (4)	Apr (36)	May (3)	Jun (7)	Jul (46)	Aug (14)	Sep (12)	Oct (2)	Nov	Dec (12)
2015	Jan (4)	Feb	Mar	Apr (80)	May (36)	Jun	Jul	Aug	Sep	Oct	Nov	Dec

r-gregmisc-users Mailing List for R gregmisc package (Page 30)

r-gregmisc-users — Discussion list for R gregmisc packages (gplot, gmodels, gdata, gtools)