R/Euler.R

In js229/Vennerable: Venn and Euler area-proportional diagrams

Euler.from.Signature <- function(Signature ) {
	w <- lapply(Signature,function(x){c(0,1)})
	names(w) <- Signature
	Eulers <- do.call(expand.grid,w)
	Eulers$ESignature <- apply(data.matrix(Eulers),1,paste,collapse="")
	Eulers
}

EulerClasses <- function(numberOfSets) {
	V <- Venn(numberOfSets=numberOfSets)
	vs <- data.frame(Indicator(V))
	vs$Signature <- apply(data.matrix(vs),1,paste,collapse="")
	#vs <- subset(vs,Signature!=dark.matter.signature(V)) # causes note in RCMD check
	vs <- vs[vs$Signature!=dark.matter.signature(V),]
	
	E2 <- Euler.from.Signature (vs$Signature)
	E2 <- E2[order(E2$ESignature),]

	#library(gtools)
	worder <-   gtools::permutations(numberOfSets,numberOfSets)
	worder <- lapply(1:nrow(worder),function(x){worder[x,]})
	P2 <- lapply(worder,function(x) {
		vs.order <- vs[,x]
		vs.order$Signature <- apply(data.matrix(vs.order),1,paste,collapse="")
		vs.perm <- match(vs.order$Signature,vs$Signature)
		E2.perm <- E2[,vs.perm]
		E2.perm$ESignature  <- apply(data.matrix(E2.perm),1,paste,collapse="")
		E2.perm$ESignature
	})


	# now E2 has the indicator strings generated by all possible orderings
	# with the corresponding row names
	E3 <- do.call(rbind,P2)
	F3 <- unique(apply(E3,2,function(x)(unique(sort(x)))))
	Emap <- do.call(rbind,lapply(F3,function(x)data.frame(ESignature=x,ESignatureCanonical=x[1])))
	Eclass <- merge(E2,Emap)
	#names(F3) <- sapply(F3,function(x)x[1])

	#iclasses <- (sapply(F3,paste,collapse=";"))
	#rclasses <- sapply(F3,function(x)x[1])
	#irclasses <- data.frame(ESignature=rclasses,iclasses=iclasses,stringsAsFactors=FALSE)
	#Eclass <- merge(E2,irclasses)
	#rownames(Eclass) <- 1:nrow(Eclass)
	#Eclass <- Eclass[order(Eclass$ESignature),]
	# now Eclass has one row for every distinct Euler pattern up to permutation
	#However some of these  correspond to
	#patterns in which every region at least one set is empty.
	vsnames <- names(E2[,!colnames(E2)%in% c("ESignature","ESignatureCanonical")])
	vsmat <- do.call(rbind,strsplit(vsnames,split=""))
	isset <- lapply(1:ncol(vsmat),function(col)vsnames[vsmat[,col]=="1"])
	haveset <- sapply(isset,function(setsigs)apply(Eclass[,setsigs],1,sum)>0)
	Eclass$SetsRepresented <- apply(haveset,1,sum)
	Eclass

}