[Vennerable-commits] r47 - in pkg/Vennerable: R inst/doc tests

[noreply at r-forge.r-project.org]

Author: js229
Date: 2009-08-23 20:08:39 +0200 (Sun, 23 Aug 2009)
New Revision: 47

Added:
   pkg/Vennerable/tests/bug0524CR1100.R
Modified:
   pkg/Vennerable/R/02TissueDrawing.R
   pkg/Vennerable/inst/doc/VennDrawingTest.Rnw
Log:
fix bug 524; which allows CR 1:16 plot

Modified: pkg/Vennerable/R/02TissueDrawing.R
===================================================================
--- pkg/Vennerable/R/02TissueDrawing.R	2009-08-06 17:02:52 UTC (rev 46)
+++ pkg/Vennerable/R/02TissueDrawing.R	2009-08-23 18:08:39 UTC (rev 47)
@@ -959,17 +959,21 @@
 	sapply(.faceNames(drawing),function(faceName)abs(.face.area(drawing,faceName)))
 }
 
-.face.centroid <- function(drawing,faceName) {
-	all.xy <- .face.toxy(drawing,faceName)
+.polygon.centroid <- function(all.xy) {
 	xy1 <- all.xy; xy2 <- all.xy[ c(2:nrow(all.xy),1),]
 	x1 <- xy1[,1];y1 <-xy1[,2];x2<-xy2[,1];y2<- xy2[,2]
-	area <- .face.area(drawing,faceName)
+	area <- .polygon.area(all.xy)
 	cx <- sum((x1+x2) * ( x1 * y2 - x2 * y1))/(6* area)
 	cy <- sum((y1+y2) * ( x1 * y2 - x2 * y1))/(6* area)
-
 	centroid.xy <- matrix(c(cx,cy),ncol=2)
+	centroid.xy
 }
 
+.face.centroid <- function(drawing,faceName) {
+	all.xy <- .face.toxy(drawing,faceName)
+	.polygon.centroid(all.xy)
+}
+
 .PlotFace.TissueDrawing <- function(drawing,faceName,dx=0.05,gp=gpar(),doDarkMatter=FALSE) {
 #cat(faceName,"\n")
 	if (!doDarkMatter & faceName=="DarkMatter") {
@@ -1055,6 +1059,7 @@
 	if (.is.point.within.face(drawing,faceName,faceCentroid)) {
 		return(faceCentroid)
 	}
+	if (faceName!="1100") { # old method 
 	# find a point on the edge which is ideally not a node
 	amidpoint <- .find.point.on.face(drawing,faceName)
 
@@ -1076,10 +1081,58 @@
 	} else{ stop(sprintf("Error in finding a point in face %s",faceName))}
 	qmid <- (q1+q2)/2
 	rownames(qmid) <- faceName
-	qmid
+		return(qmid)
+	} # old method
+	ear.triangle <- .find.triangle.within.face(drawing,faceName)
+	earCentroid <- .polygon.centroid(ear.triangle)
+	if (!	.is.point.within.face(drawing,faceName,earCentroid )) {
+		stop("Ear method failed in face %s\n",faceName)
+	}
+	return(earCentroid)
+}
 
+.find.triangle.within.face <- function(drawing,faceName) {
+	# poor mans triangulation... subtracting ear method cf wikipedia polygon triangulation
+	xy <- .face.toxy(drawing,faceName)
+	xy <- rbind(xy,xy[1:2,])
+	fix <- NA
+	for (ix in 2:(nrow(xy)-1)) {
+		from <- xy[ix-1,,drop=FALSE]
+		to <- xy[ix+1,,drop=FALSE]
+		pt <- xy[ix,,drop=FALSE]
+		thetafrom <- atan2( from[,2]-pt[,2],from[,1]-pt[,1])
+		thetato <-   atan2(   to[,2]-pt[,2],to[,1]-pt[,1])
+		thetato <- thetato - thetafrom
+		thetato <- thetato %% (2 * pi)
+		if (thetato > pi) { # not a convex point
+			next
+		}
+		npoints <- .probe.chord.intersections(drawing,faceName,from,to)
+		fromdist <- ((npoints[,1]-from[1])^2+(npoints[,2]-from[2])^2 ) * sign(npoints[,1]-from[1])
+		npoints <- npoints[order(fromdist),]; fromdist <- sort(fromdist)
+		fromix <- min(which(fequal(fromdist,0)))
+		if (fromix !=1) {
+			fromdist <- -fromdist
+			npoints <- npoints[order(fromdist),];fromdist <- sort(fromdist)
+			fromix <- min(which(fequal(fromdist,0)))
+			stopifnot(fromix==1)
+		}
+		# the next point along has to be the to point otherwise intersection
+		nextix <- min(which(!fequal(fromdist,0)))
+		nextpt <- npoints[nextix,,drop=FALSE]
+		nointersect <- all(fequal(nextpt,to))
+		if (nointersect) {
+			fix <- ix
+			break
+		}
+	}
+	if (is.na(fix)) {
+		stop(sprintf("Can't find ears for face %s\n",faceName))
+	}
+	return(xy[ (fix-1):(fix+1),])
 }
 
+
 internalPointsofFaces <- function(drawing) {
 	fNames <-setdiff(.faceNames(drawing),"DarkMatter") 
 	res <- lapply(fNames ,function(x).find.point.within.face(drawing=drawing,x))
@@ -1683,7 +1736,9 @@
 	}	
 	# now we have a collection of points at which the chord crosses the face
 	ipoints <- do.call(rbind,lapply(names(foundList),
-		function(x){y<-foundList[[x]];if(nrow(y)>0){rownames(y)<-paste(x,seq_len(nrow(y)),sep=";")};y})
+		function(x){
+			y<-foundList[[x]];
+			if(nrow(y)>0){rownames(y)<-paste(x,seq_len(nrow(y)),sep=";")};y})
 		)
 	# we want to order them along the line of the chord
 	npoints <- rbind(ipoints,chord.from.xy)

Modified: pkg/Vennerable/inst/doc/VennDrawingTest.Rnw
===================================================================
--- pkg/Vennerable/inst/doc/VennDrawingTest.Rnw	2009-08-06 17:02:52 UTC (rev 46)
+++ pkg/Vennerable/inst/doc/VennDrawingTest.Rnw	2009-08-23 18:08:39 UTC (rev 47)
@@ -696,12 +696,7 @@
 <<plotCR4,echo=FALSE,fig=TRUE>>=
 CR4a <-  compute.CR(V4a)
 grid.newpage()
-PlotVennGeometry(CR4a,show=list(FaceText=character(0)))
-try( {
-	PlotVennGeometry(CR4a ,show=list(FaceText="signature"))
-	# TODO this fails 1011 and 0111
-	}
-)
+PlotVennGeometry(CR4a ,show=list(FaceText="signature"))
 checkAreas(CR4a )
 @
 \caption{Chow-Ruskey weighted 4-set diagram, produces an error if we try to plot signature face text}

Added: pkg/Vennerable/tests/bug0524CR1100.R
===================================================================
--- pkg/Vennerable/tests/bug0524CR1100.R	                        (rev 0)
+++ pkg/Vennerable/tests/bug0524CR1100.R	2009-08-23 18:08:39 UTC (rev 47)
@@ -0,0 +1,4 @@
+library(Vennerable)
+V4a <- Venn(SetNames=month.name[1:4],Weight=1:16)
+CR4a <-  compute.CR(V4a)
+IntersectionMidpoints(CR4a)