[R-gregmisc-commits] r2090 - in pkg/gplots: R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Mar 24 16:01:03 CET 2016
Author: warnes
Date: 2016-03-24 16:01:02 +0100 (Thu, 24 Mar 2016)
New Revision: 2090
Added:
pkg/gplots/R/vennMembers.R
Modified:
pkg/gplots/R/venn.R
pkg/gplots/man/venn.Rd
Log:
The 'intersections' attribute returned from venn() has been improved to use set names instead of indicators, and is ordered from simplest to most complex set interactions.
Modified: pkg/gplots/R/venn.R
===================================================================
--- pkg/gplots/R/venn.R 2016-03-24 13:47:48 UTC (rev 2089)
+++ pkg/gplots/R/venn.R 2016-03-24 15:01:02 UTC (rev 2090)
@@ -34,121 +34,121 @@
# l offers a list of arrays, their values are to
# be tested for the size of their intersects.
getVennCounts.list<-function(l, universe=NA, verbose=F, intersections=TRUE) {
- if (verbose) cat("Interpreting data as list.\n")
- numSets<-length(l)
- result.table<-NULL
- result.table.names<-NULL
+ if (verbose) cat("Interpreting data as list.\n")
+ numSets<-length(l)
+ result.table<-NULL
+ result.table.names<-NULL
- memberList <- list()
+ memberList <- list()
- # Iteration over all possible intersections involving all sets
- # or the complement (negation) of those sets.
- for (i in 0:(-1 + 2^numSets)) {
- # i2 is a binary representation of that number
- i2<-baseOf(i,2,numSets)
+ # Iteration over all possible intersections involving all sets
+ # or the complement (negation) of those sets.
+ 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="")))
+ # 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
+ # p.pos determines the position in number
+ # which is also the set that is inspected
- sel<-universe
+ sel<-universe
- # positive selection first
- for (p.pos in which(1 == i2) ) {
- current.set<-l[[p.pos]]
- if (!is.null(dim(current.set))) {
- # circumventing strange experiences with data.frames
- warning(paste("List element [[",p.pos,"]] has dimensions, but all elements are considered.\n",sep=""))
- current.set<-as.character(as.matrix(current.set))
- dim(current.set)<-NULL
- }
- #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
- }
- }
- }
+ # positive selection first
+ for (p.pos in which(1 == i2) ) {
+ current.set<-l[[p.pos]]
+ if (!is.null(dim(current.set))) {
+ # circumventing strange experiences with data.frames
+ warning(paste("List element [[",p.pos,"]] has dimensions, but all elements are considered.\n",sep=""))
+ current.set<-as.character(as.matrix(current.set))
+ dim(current.set)<-NULL
+ }
+ #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
+ # 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]]
- if (!is.null(dim(current.set))) {
- warning(paste("List element [[",p.pos,"]] has dimensions, but all elements are considered.\n",sep=""))
- current.set<-as.character(as.matrix(current.set))
- dim(current.set)<-NULL
- }
- 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=",")))
+ # 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]]
+ if (!is.null(dim(current.set))) {
+ warning(paste("List element [[",p.pos,"]] has dimensions, but all elements are considered.\n",sep=""))
+ current.set<-as.character(as.matrix(current.set))
+ dim(current.set)<-NULL
+ }
+ 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
- }
+ if(is.null(sel) || (1 == length(sel) && is.na(sel))) {
+ sel<-NULL
+ }
- r.name<-paste(i2,collapse="")
- if (intersections) {
- memberList[[r.name]] <- sel
- }
+ r.name<-paste(i2,collapse="")
+ if (intersections) {
+ memberList[[r.name]] <- sel
+ }
- r<-length(sel)
- 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))
- }
- if (intersections) {
- attr(result.table,"intersections") <- memberList
- }
- class(result.table) <- "venn"
- return(result.table)
+ r<-length(sel)
+ 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))
+ }
+ if (intersections) {
+ attr(result.table,"intersections") <- memberList
+ }
+ class(result.table) <- "venn"
+ return(result.table)
}
#print(getVennCounts(list(A,B,C,D)))
@@ -160,17 +160,30 @@
showSetLogicLabel=FALSE,
simplify=FALSE,
show.plot=TRUE,
- intersections=TRUE)
+ intersections=TRUE,
+ names,
+ ...
+ )
{
- counts <- getVennCounts(data, universe=universe, intersections=intersections)
-
+ counts <- getVennCounts(data,
+ universe=universe,
+ intersections=intersections
+ )
+
if(show.plot)
drawVennDiagram(data=counts,
small=small,
showSetLogicLabel=showSetLogicLabel,
- simplify=simplify
+ simplify=simplify,
+ ...
)
+ # use VennMemberNames to properly label and order the 'intersection' table
+ if(intersections)
+ attr(counts, "intersections") <- vennMembers(l=data,
+ universe=universe,
+ names=names
+ )
invisible(counts)
}
Added: pkg/gplots/R/vennMembers.R
===================================================================
--- pkg/gplots/R/vennMembers.R (rev 0)
+++ pkg/gplots/R/vennMembers.R 2016-03-24 15:01:02 UTC (rev 2090)
@@ -0,0 +1,41 @@
+# Extract intersections
+vennMembers <- function(l, universe=NA, names, ...)
+{
+ venn_object <- getVennCounts(l, universe, intersections=TRUE, ...)
+ map <- attr(venn_object, "intersections")
+ if(missing(names))
+ names <- colnames(venn_object)[-1]
+
+ if(is.matrix(l) || is.data.frame(l))
+ {
+ ids <- rownames(l)
+ retval <- list()
+ for(i in names(map))
+ retval[[i]] <- ids[map[[i]]]
+ }
+ else if(is.list(l))
+ retval <- map
+
+
+ flags <- do.call(rbind, strsplit(names(map), character(0), fixed=TRUE))
+ rownames(flags) <- names(map)
+ colnames(flags) <- names
+ nameList <- list()
+ for(i in 1:nrow(flags)) nameList[[i]] <- ifelse(flags[i,]=="1", colnames(flags), "")
+ nameList <- do.call(data.frame,nameList)
+ nameList <- apply(nameList, 2, paste, collapse=":")
+ nameList <- gsub('::+', ':', nameList)
+ nameList <- gsub('^:+', '', nameList)
+ nameList <- gsub(':+$', '', nameList)
+
+ names(retval) <- nameList
+
+ sortTab <- cbind(sapply(nameList, nchar), nameList)
+ ord <- order(sortTab[,1], sortTab[,2])
+
+ retval <- retval[ord]
+
+ retval <- lapply(retval, as.character)
+
+ retval
+}
Modified: pkg/gplots/man/venn.Rd
===================================================================
--- pkg/gplots/man/venn.Rd 2016-03-24 13:47:48 UTC (rev 2089)
+++ pkg/gplots/man/venn.Rd 2016-03-24 15:01:02 UTC (rev 2090)
@@ -7,7 +7,7 @@
}
\usage{
venn(data, universe=NA, small=0.7, showSetLogicLabel=FALSE,
- simplify=FALSE, show.plot=TRUE, intersections=TRUE)
+ simplify=FALSE, show.plot=TRUE, intersections=TRUE, names)
\method{plot}{venn}(x, y, ..., small=0.7, showSetLogicLabel=FALSE,
simplify=FALSE)
}
@@ -40,10 +40,16 @@
names.
}
\value{
- Invisibly returns an object of class "venn", containing a matrix of
- all possible sets of groups, and the observed count of items belonging
- to each The fist column contains observed counts, subsequent columns
- contain 0-1 indicators of group intersectionship.
+ Invisibly returns an object of class "venn", containing:
+ \itemize{
+ \item A matrix of all possible sets of groups, and the observed count
+ of items belonging to each The fist column contains observed
+ counts, subsequent columns contain 0-1 indicators of group
+ intersectionship.
+ \item If \code{intersections=TRUE}, the attribute \code{intersections}
+ will be a list of vectors containing the names of the elements
+ belonging to each subset.
+ }
}
\author{
Steffen Moeller \email{steffen\_moeller at gmx.de},
@@ -114,34 +120,34 @@
##
## Example to determine which elements are in A and B but not in
-## C and D: first determine the universe, then form indicator columns
-## and perform intersections on these. R allows using the set operations
-## directly, but some might find this approach more intuitive.
+## C and D using the 'intersections' attribute.
##
+tmp <- venn(input, intersection=TRUE)
+isect <- attr(tmp, "intersection")
-universe <- unique(c(GroupA,GroupB,GroupC,GroupD))
-GroupA.l <-universe \%in\% GroupA
-GroupB.l <-universe \%in\% GroupB
-GroupC.l <-universe \%in\% GroupC
-GroupD.l <-universe \%in\% GroupD
+# Look at all of the subsets
+str(isect)
-## Genes that are in GroupA and in GroupB but not in GroupD (unification
-## of sets III0 and II00 in the venn diagram:
-universe[GroupA.l & GroupB.l & !GroupD.l]
+# Extract and combine the subsets of interest..
+AandB <- unique(c(int$A, int$B, int$'A:B'))
-##
-## Alternatively: construct a function to test for the pattern you want.
-##
-test <- function(x) (x \%in\% GroupA) & (x \%in\% GroupB) & !(x \%in\% GroupC)
-universe[ test(universe) ]
+# and look at the results
+str(AandB)
##
-## Intriduced with gplots 2.16, the names of individuals for everz intersection
-## is offered as an attribute to the retrun value.
+## The full set of elements of each intersection is provided in the
+## "interesections" attribute.
##
a<-venn(list(1:5,3:8), show.plot=FALSE)
intersections<-attr(a,"intersections")
print(intersections)
-
+# $A
+# [1] "1" "2"
+#
+# $B
+# [1] "6" "7" "8"
+#
+# $`A:B`
+# [1] "3" "4" "5"
}
\keyword{hplot}
More information about the R-gregmisc-commits
mailing list