[adegenet-commits] r127 - in pkg: R man

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

Author: jombart
Date: 2008-06-18 10:31:22 +0200 (Wed, 18 Jun 2008)
New Revision: 127

Added:
   pkg/R/normalize.R
Removed:
   pkg/R/scale.R
Modified:
   pkg/R/makefreq.R
   pkg/man/makefreq.Rd
Log:
Added truenames arg to makefreq.
Method 'normalize' (can't use scale) for both classes.


Modified: pkg/R/makefreq.R
===================================================================
--- pkg/R/makefreq.R	2008-06-14 16:56:38 UTC (rev 126)
+++ pkg/R/makefreq.R	2008-06-18 08:31:22 UTC (rev 127)
@@ -1,7 +1,7 @@
 ####################
 # Function makefreq
 ####################
-makefreq <- function(x,quiet=FALSE,missing=NA){
+makefreq <- function(x,quiet=FALSE,missing=NA,truenames=TRUE){
 
   if(!is.genpop(x)) stop("x is not a valid genpop object")
 
@@ -9,15 +9,15 @@
 
   f1 <- function(v){
     if(all(is.na(v)) || sum(v,na.rm=TRUE)==0) return(rep(NA,length(v)))
-    return(v/(sum(v,na.rm=TRUE)))       
+    return(v/(sum(v,na.rm=TRUE)))
   }
 
   res <- list()
-  
+
   tabcount <- x at tab
-  
-  eff.pop <- t(apply(tabcount,1,function(r) tapply(r,x at loc.fac,sum,na.rm=TRUE)))  
-   
+
+  eff.pop <- t(apply(tabcount,1,function(r) tapply(r,x at loc.fac,sum,na.rm=TRUE)))
+
   # tabfreq is a pop x loci table of allelic frequencies
   tabfreq <- t(apply(tabcount,1,function(r) unlist(tapply(r,x at loc.fac,f1))))
   colnames(tabfreq) <- colnames(x at tab)
@@ -29,8 +29,8 @@
     if(toupper(missing)=="MEAN") {
       moy <- apply(tabfreq,2,function(c) mean(c,na.rm=TRUE))
       for(j in 1:ncol(tabfreq)) {tabfreq[,j][is.na(tabfreq[,j])] <- moy[j]}
-    }        
-  }  
+    }
+  }
 
   if(!quiet) cat("\n...done.\n\n")
 
@@ -38,6 +38,16 @@
   res$nobs <- eff.pop
   res$call <- match.call()
 
+  ## handle truenames
+  if(truenames){
+      temp <- rep(x at loc.names,x at loc.nall)
+      colnames(res$tab) <- paste(temp,unlist(x at all.names),sep=".")
+      rownames(res$tab) <- x at pop.names
+
+      colnames(res$nobs) <- x at loc.names
+      rownames(res$nobs) <- x at pop.names
+  }
+
   return(res)
 } #end makefreq
 

Added: pkg/R/normalize.R
===================================================================
--- pkg/R/normalize.R	                        (rev 0)
+++ pkg/R/normalize.R	2008-06-18 08:31:22 UTC (rev 127)
@@ -0,0 +1,61 @@
+####################
+# normalize methods
+####################
+setGeneric("normalize", function(x,...){standardGeneric("normalize")})
+
+setMethod("normalize", "genind", function(x, center=TRUE, scale=TRUE,
+                                      method=c("sigma", "binom"), truenames=TRUE){
+
+    method <- match.arg(method)
+    
+    ## handle specific cases
+    if(scale & tolower(method)=="binom"){
+        ## get allele freq
+        temp <- apply(x$tab,2,mean,na.rm=TRUE)
+        ## coerce sum of alleles freq to one (in case of missing data)
+        temp <- tapply(temp, x$loc.fac, function(vec) return(vec/sum(vec)))
+        pbar <- unlist(temp)
+
+        scale <- sqrt(pbar*(1-pbar))
+    }
+
+    X <- x$tab
+    ## handle truenames
+    if(truenames){
+        X <- truenames(x)
+        if(is.list(X)) { X <- X$tab }
+    }
+    
+    ## return result
+    res <- scale(X, center=center, scale=scale)
+    return(res)
+})
+
+
+
+
+
+setMethod("normalize", "genpop", function(x, center=TRUE, scale=TRUE,
+                                      method=c("sigma", "binom"), missing=NA, truenames=TRUE){
+
+    method <- match.arg(method)
+
+    ## make allele frequencies here
+    X <- makefreq(x,quiet=TRUE,missing=missing,truenames=truenames)$tab
+
+    ## handle specific cases
+    if(scale & tolower(method)=="binom"){
+        ## get allele freq
+        temp <- apply(X,2,mean,na.rm=TRUE)
+        ## coerce sum of alleles freq to one (in case of missing data)
+        temp <- tapply(temp, x$loc.fac, function(vec) return(vec/sum(vec)))
+        pbar <- unlist(temp)
+
+        scale <- sqrt(pbar*(1-pbar))
+    }
+
+    ## return result
+
+    res <- scale(X, center=center, scale=scale)
+    return(res)
+})

Deleted: pkg/R/scale.R
===================================================================
--- pkg/R/scale.R	2008-06-14 16:56:38 UTC (rev 126)
+++ pkg/R/scale.R	2008-06-18 08:31:22 UTC (rev 127)
@@ -1,32 +0,0 @@
-################
-# scale methods
-################
-setGeneric("scaleGen", function(x,...){standardGeneric("scaleGen")})
-
-setMethod("scaleGen", "genind", function(x, center=TRUE, scale=TRUE,
-                                      method=c("sigma", "binom"), truenames=TRUE){
-
-    method <- match.arg(method)
-    
-    ## handle specific cases
-    if(scale & tolower(method)=="binom"){
-        ## get allele freq
-        temp <- apply(x$tab,2,mean,na.rm=TRUE)
-        ## coerce sum of alleles freq to one (in case of missing data)
-        temp <- tapply(temp, x$loc.fac, function(vec) return(vec/sum(vec)))
-        pbar <- unlist(temp)
-
-        scale <- sqrt(pbar*(1-pbar))
-    }
-
-    X <- x$tab
-    ## handle truenames
-    if(truenames){
-        X <- truenames(x)
-        if(is.list(X)) { X <- X$tab }
-    }
-    
-    ## return result
-    res <- scale(X, center=center, scale=scale)
-    return(res)
-})

Modified: pkg/man/makefreq.Rd
===================================================================
--- pkg/man/makefreq.Rd	2008-06-14 16:56:38 UTC (rev 126)
+++ pkg/man/makefreq.Rd	2008-06-18 08:31:22 UTC (rev 127)
@@ -6,7 +6,7 @@
   frequencies from an object of class \code{genpop}.
 }
 \usage{
-makefreq(x,quiet=FALSE,missing=NA)
+makefreq(x,quiet=FALSE,missing=NA,truenames=TRUE)
 }
 \arguments{
   \item{x}{an object of class \code{genpop}.}
@@ -14,6 +14,8 @@
     printed (TRUE,default) or not (FALSE).}
   \item{missing}{treatment for missing values. Can be NA, 0 or "mean"
     (see details)}
+  \item{truenames}{a logical indicating whether true labels (as opposed
+    to generic labels) should be used to name the output.}
 }
 \details{There are 3 treatments for missing values: \cr
   - NA: kept as NA.\cr