[Adephylo-commits] r174 - in pkg: . R src

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

Author: jombart
Date: 2012-02-08 20:02:42 +0100 (Wed, 08 Feb 2012)
New Revision: 174

Added:
   pkg/R/tree.group.R
Modified:
   pkg/DESCRIPTION
   pkg/src/distPhylo.c
Log:
Added development stuff


Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION	2011-11-07 08:33:35 UTC (rev 173)
+++ pkg/DESCRIPTION	2012-02-08 19:02:42 UTC (rev 174)
@@ -1,6 +1,6 @@
 Package: adephylo
-Version: 1.1-2
-Date: 2011/11/07
+Version: 1.1-3
+Date: 2012/01/20
 Title: adephylo: exploratory analyses for the phylogenetic comparative method.
 Author: Thibaut Jombart <t.jombart at imperial.ac.uk>, Stephane Dray <stephane.dray at univ-lyon1.fr>
 Maintainer: Thibaut Jombart <t.jombart at imperial.ac.uk>

Added: pkg/R/tree.group.R
===================================================================
--- pkg/R/tree.group.R	                        (rev 0)
+++ pkg/R/tree.group.R	2012-02-08 19:02:42 UTC (rev 174)
@@ -0,0 +1,58 @@
+treeGroup <- function(x, grp, dat, FUN, n.boot=10,
+                      n.dens=4096,
+                      plot=TRUE, ...){
+    if(!require(ape)) stop("ape package is required")
+    if(!inherits(x,"phylo")) stop("x is not a phylo object")
+    grp <- factor(grp)
+    k <- length(lev <- levels(grp))
+    n <- nrow(dat)
+    D <- cophenetic.phylo(x)
+
+
+    ## FUNCTION TO ESTIMATE A DENSITY AT A GIVEN POINT ##
+    find.dens <- function(dens, value){
+        if(value<=min(dens$x)) return((dens$y[1]+0) / 2)
+        if(value>=max(dens$x)) return((dens$y[length(dens$y)]+0) / 2)
+        idx <- min(which(c(dens$x > value)))
+        return(mean(dens$y[c(idx,idx+1)]))
+    }
+
+
+    ## FUNCTION TO GET A VECTOR OF PAIRWISE DISTANCE FOR ONE GROUP ##
+    getdist.grp <- function(M, g){
+        temp <- M[grp==g,grp==g]
+        return(temp[lower.tri(temp)])
+    }
+
+
+    ## FUNCTION TO GET PROBA FOR ONE INDIV / ONE GROUP ##
+    getprob.grp <- function(i, g){ # g indicates a group
+        find.dens(list.dens[[g]] D[i,grp==lev[g]])
+        temp <- D[,grp==g]
+
+    }
+
+
+    ## PERFORM BOOTSTRAP TREES ##
+    list.trees <- lapply(1:n.boot, function(i) FUN(dat[sample(1:n,replace=TRUE),]))
+
+
+    ## GET WITHIN-GROUP DISTANCES FOR EACH BOOTSTRAP SAMPLE ##
+    list.D <- lapply(list.trees, cophenetic.phylo)
+    list.D <- lapply(lev, function(g) unlist(lapply(listD, function(e) getdist.grp(e,g))))
+
+
+    ## COMPUTE DENSITIES ##
+    list.dens <- lapply(list.D, density, n=n.dens, ...)
+    if(plot){
+        par(mfrow = c(ceiling(sqrt(k)),ceiling(sqrt(k))) )
+        for(i in 1:k){
+            plot(list.dens[[i]], main=paste("Group:",lev[i]),xlab="Phylogenetic pairwise distance",ylab="Density", col="blue")
+            points(list.D[[i]], rep(0,length(list.D[[i]])), pch="|", col="blue")
+        }
+    }
+
+
+
+
+}

Modified: pkg/src/distPhylo.c
===================================================================
--- pkg/src/distPhylo.c	2011-11-07 08:33:35 UTC (rev 173)
+++ pkg/src/distPhylo.c	2012-02-08 19:02:42 UTC (rev 174)
@@ -267,6 +267,60 @@
 
 
 
+
+
+
+/* /\* === FIND DISTANCES BETWEEN GIVEN PAIRS OF TIPS === *\/ */
+/* /\* === THIS HAS NOT BEEN TESTED === *\/ */
+/* void distpairtips(int *ances, int *desc, double *brlength, int *N, int *nTips, double *res, int *resSize, int *method, int *tipsA, int *tipsB){ */
+/* 	/\* declarations *\/ */
+/* 	int i, j, k, temp; */
+/* 	int *ancesLoc, *descLoc; /\* must use dynamic allocation *\/ */
+/* 	double *brlengthLoc; /\* must use dynamic allocation *\/ */
+
+/* 	/\* check resSize *\/ */
+/* 	temp = (*nTips) * (*nTips-1) / 2; */
+/* 	if(*resSize !=  temp) { */
+/* 		printf("\n Likely error in distalltips: resSize is %d, and should be %d.\n", *resSize, temp); */
+/* 		return; */
+/* 	} */
+
+
+/* 	/\* allocate memory for local variables *\/ */
+/* 	vecintalloc(&ancesLoc, *N); */
+/* 	vecintalloc(&descLoc, *N); */
+/* 	vecalloc(&brlengthLoc, *N); */
+
+
+/* 	/\* create local vectors for ancestors, descendents and branch lengths *\/ */
+/* 	ancesLoc[0] = *N; */
+/* 	descLoc[0] = *N; */
+/* 	brlengthLoc[0] = *N ; /\* implicit casting int->double *\/ */
+/* 	for(i=0; i< *N; i++){ */
+/* 		ancesLoc[i+1] = ances[i]; */
+/* 		descLoc[i+1] = desc[i]; */
+/* 		brlengthLoc[i+1] = brlength[i]; */
+/* 	} */
+
+
+/* 	/\* perform computations for all pairs of tips (indexed 'i,j') *\/ */
+/* 	k = 0; /\* used to browse 'res' *\/ */
+
+/* 	for(i=0; i<*resSize; i++){ */
+/* 		res[k++] = dist2tips(ancesLoc, descLoc, brlengthLoc, *N, tipsA[i], tipsB[j], *method); */
+/* 		/\*printf("\nDistance between tip %d and %d in main function: %f", i, j, res[k]);*\/ */
+/* 	} */
+
+/* 	/\* free memory *\/ */
+/* 	freeintvec(ancesLoc); */
+/* 	freeintvec(descLoc); */
+/* 	freevec(brlengthLoc); */
+
+/* } /\* end distpairtips *\/ */
+
+
+
+
 /* TESTING */
 /*