[adegenet-commits] r239 - pkg/R

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

Author: jombart
Date: 2009-01-25 17:48:03 +0100 (Sun, 25 Jan 2009)
New Revision: 239

Modified:
   pkg/R/fstat.R
   pkg/R/genind2genpop.R
Log:
checkTypes...


Modified: pkg/R/fstat.R
===================================================================
--- pkg/R/fstat.R	2009-01-25 16:42:43 UTC (rev 238)
+++ pkg/R/fstat.R	2009-01-25 16:48:03 UTC (rev 239)
@@ -9,7 +9,8 @@
     if(!is.genind(x)) stop("x is not a valid genind object")
     if(!require(hierfstat)) stop("hierfstat package is required. Please install it.")
     if(x at ploidy != as.integer(2)) stop("not implemented for non-diploid genotypes")
-    
+    checkType(x)
+
     if(is.null(pop)) pop <- x at pop
     if(is.null(pop)) stop("no pop factor provided")
     if(length(pop)!=nrow(x at tab)) stop("pop has a wrong length.")
@@ -34,12 +35,12 @@
 ##     ## misc checks
 ##     if(!is.genind(x)) stop("x is not a valid genind object")
 ##     if(!require(hierfstat)) stop("hierfstat package is required. Please install it.")
-    
+
 ##     if(is.null(pop)) pop <- x at pop
 ##     if(is.null(pop)) stop("no pop factor provided")
 ##     if(length(pop)!=nrow(x at tab)) stop("pop has a wrong length.")
 
 ##     ## computations
-    
+
 ##     return(res)
 ## }

Modified: pkg/R/genind2genpop.R
===================================================================
--- pkg/R/genind2genpop.R	2009-01-25 16:42:43 UTC (rev 238)
+++ pkg/R/genind2genpop.R	2009-01-25 16:48:03 UTC (rev 239)
@@ -4,14 +4,15 @@
 genind2genpop <- function(x,pop=NULL,missing=c("NA","0","chi2"),quiet=FALSE){
 
   if(!is.genind(x)) stop("x is not a valid genind object")
-  
+  checkType(x)
+
   if(is.null(x at pop) && is.null(pop)) stop("pop is not provided either in x or in pop")
 
   missing <- match.arg(missing)
 
   if(!quiet) cat("\n Converting data from a genind to a genpop object... \n")
-  
-  # choose pop argument over x at pop
+
+  ## choose pop argument over x at pop
    if(!is.null(pop)) {
     if(length(pop) != nrow(x at tab)) stop("inconsistent length for factor pop")
     # keep levels in order of appearance
@@ -47,44 +48,17 @@
     tabcount <- matrix(tabcount,nrow=1)
     colnames(tabcount) <- lab.col
   }
-##   #meancol <- apply(tabcount,2,function(c) mean(c,na.rm=TRUE)) ## no longer used
 
-##   # NA treatment
-##   # Treatment when missing='REPLACE':
-##   # if allele 'j' of locus 'k' in pop 'i' is missing, replace the NA by a number 'x' so that
-##   # the frequency 'x/s' ('s' being the number of observations in 'k' ) equals the frequency 'f'
-##   # computed on the whole data (i.e. considering all pop as one)
-##   # Then x must verify:
-##   # x/s = f(1-f) => x=f(1-f)s
-##   #
-##   # - eff.pop is a pop x locus matrix giving the corresponding sum of observations (i.e., 's')
-##   # - temp is the same table but duplicated for all alleles
-##   # - odd.vec is the vector of 'f(1-f)'
-##   # - count.replace is a pop x alleles table yielding appropriate replacement numbers (i.e., 'x')
-
-##   if(!is.na(missing) && any(is.na(tabcount))){
-##     if(missing==0) tabcount[is.na(tabcount)] <- 0
-##     if(toupper(missing)=="REPLACE") {
-##     eff.pop <- t(apply(tabcount,1,function(r) tapply(r,x at loc.fac,sum,na.rm=TRUE)))
-##     temp <- t(apply(eff.pop,1,function(r) rep(r,table(x at loc.fac))))
-
-##     freq.allpop <- apply(tabcount,2,sum,na.rm=TRUE)
-##     freq.allpop <- unlist(tapply(freq.allpop,x at loc.fac,f2))
-##     odd.vec <- freq.allpop/(1-freq.allpop)
-  
-##     count.replace <- t(apply(temp,1,function(r) r*odd.vec))
-
-##     tabcount[is.na(tabcount)] <- count.replace[is.na(tabcount)]
-##     }
-##   } # end of NA treatment
-
-  
   ## make final object
-  temp <- paste(rep(x at loc.names,x at loc.nall),unlist(x at all.names),sep=".")
+  if(x at type=="codom"){
+      temp <- paste(rep(x at loc.names,x at loc.nall),unlist(x at all.names),sep=".")
+  } else{
+      temp <- x at loc.names
+  }
   colnames(tabcount) <- temp
 
   prevcall <- match.call()
-  
+
   res <- genpop(tab=tabcount, prevcall=prevcall)
   res at other <- x at other
 
@@ -95,5 +69,5 @@
   if(!quiet) cat("\n...done.\n\n")
 
   return(res)
-  
+
 } # end genind2genpop