[adegenet-commits] r142 - in pkg: . R

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

Author: jombart
Date: 2008-06-29 17:18:31 +0200 (Sun, 29 Jun 2008)
New Revision: 142

Modified:
   pkg/R/basicMethods.R
   pkg/R/propTyped.R
   pkg/TODO
Log:
Various fixes (computation of NA %, propTyped weighted for genpop obj).


Modified: pkg/R/basicMethods.R
===================================================================
--- pkg/R/basicMethods.R	2008-06-29 14:16:01 UTC (rev 141)
+++ pkg/R/basicMethods.R	2008-06-29 15:18:31 UTC (rev 142)
@@ -111,7 +111,8 @@
 
   res$pop.nall <- apply(temp,1,function(r) sum(r!=0,na.rm=TRUE))
 
-  res$NA.perc <- 100*sum(is.na(x at tab))/prod(dim(x at tab))
+  ##  res$NA.perc <- 100*sum(is.na(x at tab))/prod(dim(x at tab)) <- wrong
+  res$NA.perc <- 100*(1-mean(propTyped(x,by="both")))
 
   ## handle heterozygosity
   if(x at ploidy > 1){
@@ -182,7 +183,17 @@
 
   res$pop.nall <- apply(x at tab,1,function(r) sum(r>0,na.rm=TRUE))
 
-  res$NA.perc <- 100*sum(is.na(x at tab))/prod(dim(x at tab))
+  ##  res$NA.perc <- 100*sum(is.na(x at tab))/prod(dim(x at tab)) <- old version
+  mean.w <- function(x,w=rep(1/length(x),length(x))){
+      x <- x[!is.na(x)]
+      w <- w[!is.na(x)]
+      w <- w/sum(w)
+      return(sum(x*w))
+  }
+  
+  w <- apply(x at tab,1,sum,na.rm=TRUE) # weights for populations
+  res$NA.perc <- 100*(1-mean.w(propTyped(x), w=w))
+  ## res$NA.perc <- 100*(1-mean(propTyped(x,by="both"))) <- old
 
   # print to screen
   listlab <- c("# Number of populations: ",

Modified: pkg/R/propTyped.R
===================================================================
--- pkg/R/propTyped.R	2008-06-29 14:16:01 UTC (rev 141)
+++ pkg/R/propTyped.R	2008-06-29 15:18:31 UTC (rev 142)
@@ -54,6 +54,14 @@
         else return(1)
     }
 
+    ## weighted mean
+    mean.w <- function(x,w=rep(1/length(x),length(x))){
+        x <- x[!is.na(x)]
+        w <- w[!is.na(x)]
+        w <- w/sum(w)
+        return(sum(x*w))
+    }
+
     ## temp is a list (one component / marker)
     ## with n values (0: not typed, 1: typed)
     kX <- seploc(x,res.type="matrix")
@@ -62,12 +70,14 @@
     ## by individual
     if(by=="pop"){
         temp <- as.data.frame(temp)
-        res <- apply(temp,1,mean)
+        w <- unlist(lapply(kX, sum,na.rm=TRUE))
+        res <- apply(temp,1,mean.w,w=w)
     }
 
     ## by locus
     if(by=="loc"){
-        res <- unlist(lapply(temp,mean))
+        w <- apply(x at tab,1,sum,na.rm=TRUE)
+        res <- unlist(lapply(temp,mean.w,w=w))
     }
 
     ## by individual and locus

Modified: pkg/TODO
===================================================================
--- pkg/TODO	2008-06-29 14:16:01 UTC (rev 141)
+++ pkg/TODO	2008-06-29 15:18:31 UTC (rev 142)
@@ -36,8 +36,8 @@
 =====================
 * implement different levels of ploidy in genind / genpop objects.
   - put some stop where needed when ploidy!=2 is not handled
-  - adapt intput functions to different degree of ploidy
-  - adapt genind2df
+  - adapt intput functions to different degree of ploidy -- done (TJ)
+  - adapt genind2df -- done (TJ)
   - look for other functions to adapt
 * implement classical Fst sensu Weir 1996
 
@@ -67,7 +67,7 @@
 * export to geneticsBase -- same thing
 * see where code needs tuning, and use C/C++
 * implement global.rtest and local.rtest for genind/genpop objects
-* Implement method "scale" for genind / genpop objects
-* Implement dudi wrappers for genind / genpop objects
+* Implement method "scale" for genind / genpop objects -- done (TJ)
+* Implement dudi wrappers for genind / genpop objects -- one step (automatic coercion as data.frames) (TJ)
 * Check the formulae provided for Reynolds (consistent with Felsenstein's
 formulae, not straightforward reading the original article)
\ No newline at end of file