[Caic-commits] r88 - pkg/R

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

Author: davidorme
Date: 2009-04-07 17:58:25 +0200 (Tue, 07 Apr 2009)
New Revision: 88

Modified:
   pkg/R/pglm.R
Log:
Fix to last commit - the rewrite in lik.lambda makes prune.single irrelevant - although this fix calls the data tidying three times

Modified: pkg/R/pglm.R
===================================================================
--- pkg/R/pglm.R	2009-04-07 15:18:30 UTC (rev 87)
+++ pkg/R/pglm.R	2009-04-07 15:58:25 UTC (rev 88)
@@ -24,7 +24,39 @@
 ## #
 
 
+## prune.single has been made redundant by expanding the existing order.D and order.V and adding code to lik.lambda
 
+## prune.single <- function(x, data, V) {
+## 
+## 	dat <- data.frame(V1 = x, row.names=rownames(dat))
+## 
+## 	nms <- row.names(dat)
+## 	if(length(nms) == 0) stop("Need to supply row names for the data")
+## 	idx <- sort(nms, index.return = TRUE)$ix
+## 	sort.nms <- sort(nms, index.return = TRUE)$x
+## 	dat <- dat[idx,]
+## 	Vnms <- row.names(V)
+## 	if(length(Vnms) == 0) stop("Need to supply row names for the Variance matrix")
+## 	idx <- sort(Vnms, index.return = TRUE)$ix
+## 	V <- V[idx, idx]
+## 	
+## 	nms <- sort(nms)
+## 	Vn <- sort(row.names(V))
+## 	idx <- which(nms != Vn)
+## 	
+## 	
+## 	if(length(idx) > 0) stop("Error, taxon names do not match")
+## 	
+## 	complete <- complete.cases(dat)
+## 	idx <- which(complete == TRUE)
+## 	V <- V[idx, idx]
+## 	x <- dat[idx]
+## 	sort.prune.names <- sort.nms[idx]
+## 	dat <- data.frame(V1 = x, row.names = sort.prune.names)
+## 
+## 	return(list(dat = dat , V = V))
+## }
+
 lik.lambda <- function(x, V, data=NULL, lambda) {
 	
 	# rewritten CDLO 30/07/08
@@ -284,48 +316,11 @@
 
 lam.test.single <- function(x, data, V, pretty=TRUE) {
 
-    ## prune.single has been made redundant by expanding the existing order.D and order.V and adding code to lik.lambda
-    ## re-instated within lam.test.single until the code is better structured.
-    prune.single <- function(x, data, V) {
-
-    	dat <- data.frame(V1 = x, row.names=rownames(dat))
-
-    	nms <- row.names(dat)
-    	if(length(nms) == 0) stop("Need to supply row names for the data")
-    	idx <- sort(nms, index.return = TRUE)$ix
-    	sort.nms <- sort(nms, index.return = TRUE)$x
-    	dat <- dat[idx,]
-    	Vnms <- row.names(V)
-    	if(length(Vnms) == 0) stop("Need to supply row names for the Variance matrix")
-    	idx <- sort(Vnms, index.return = TRUE)$ix
-    	V <- V[idx, idx]
+	# currently inefficient - since it sorts the data out three times
+	ml.lam <- maxLik.lambda(x, V, data)
+	lam0 <- lik.lambda(x, V, data, 0)
+	lam1 <- lik.lambda(x, V, data, 1)
 	
-    	nms <- sort(nms)
-    	Vn <- sort(row.names(V))
-    	idx <- which(nms != Vn)
-	
-	
-    	if(length(idx) > 0) stop("Error, taxon names do not match")
-	
-    	complete <- complete.cases(dat)
-    	idx <- which(complete == TRUE)
-    	V <- V[idx, idx]
-    	x <- dat[idx]
-    	sort.prune.names <- sort.nms[idx]
-    	dat <- data.frame(V1 = x, row.names = sort.prune.names)
-
-    	return(list(dat = dat , V = V))
-    }
-
-	prune.dat <- prune.single(x, data, V)
-	
-	Vmat <- prune.dat$V
-	data <- prune.dat$dat
-
-	ml.lam <- maxLik.lambda(data[,1], Vmat, data)
-	lam0 <- lik.lambda(data[,1], Vmat, data, 0)
-	lam1 <- lik.lambda(data[,1], Vmat, data, 1)
-	
 	lrt0 <- 2 * (-ml.lam$objective - lam0$ll)
 	lrt1 <- 2 * (-ml.lam$objective - lam1$ll)