[adegenet-commits] r143 - pkg/R

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

Author: jombart
Date: 2008-06-29 17:38:07 +0200 (Sun, 29 Jun 2008)
New Revision: 143

Modified:
   pkg/R/HWE.R
   pkg/R/auxil.R
   pkg/R/fstat.R
   pkg/R/gstat.randtest.R
   pkg/R/hybridize.R
   pkg/R/old2new.R
Log:

Added a few test for ploidy levels.


Modified: pkg/R/HWE.R
===================================================================
--- pkg/R/HWE.R	2008-06-29 15:18:31 UTC (rev 142)
+++ pkg/R/HWE.R	2008-06-29 15:38:07 UTC (rev 143)
@@ -5,7 +5,8 @@
 HWE.test.genind <- function(x,pop=NULL,permut=FALSE,nsim=1999,hide.NA=TRUE,res.type=c("full","matrix")){
   
   if(!is.genind(x)) stop("x is not a valid genind object")
-
+  if(x at ploidy != as.integer(2)) stop("not implemented for non-diploid genotypes")
+  
   if(!require(genetics)) stop("genetics package is required. Please install it.")
   if(is.null(pop)) pop <- x at pop
   if(is.null(pop)) pop <- as.factor(rep("P1",nrow(x at tab)))

Modified: pkg/R/auxil.R
===================================================================
--- pkg/R/auxil.R	2008-06-29 15:18:31 UTC (rev 142)
+++ pkg/R/auxil.R	2008-06-29 15:38:07 UTC (rev 143)
@@ -420,8 +420,9 @@
     if(!all(sapply(x,is.genind))) stop("x is does not contain only valid genind objects")
     temp <- sapply(x,function(e) e$loc.names)
     if(!all(table(temp)==length(x))) stop("markers are not the same for all objects")
+    temp <- sapply(x,function(e) e$ploidy)
+    if(length(unique(temp)) != as.integer(1)) stop("objects have different levels of ploidy")
     
-    
     ## extract info
     listTab <- lapply(x,genind2df,usepop=FALSE)
     getPop <- function(obj){

Modified: pkg/R/fstat.R
===================================================================
--- pkg/R/fstat.R	2008-06-29 15:18:31 UTC (rev 142)
+++ pkg/R/fstat.R	2008-06-29 15:38:07 UTC (rev 143)
@@ -8,6 +8,7 @@
     ## 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(x at ploidy != as.integer(2)) stop("not implemented for non-diploid genotypes")
     
     if(is.null(pop)) pop <- x at pop
     if(is.null(pop)) stop("no pop factor provided")

Modified: pkg/R/gstat.randtest.R
===================================================================
--- pkg/R/gstat.randtest.R	2008-06-29 15:18:31 UTC (rev 142)
+++ pkg/R/gstat.randtest.R	2008-06-29 15:38:07 UTC (rev 143)
@@ -5,7 +5,7 @@
                            sup.pop=NULL, sub.pop=NULL, nsim=499){
   
   if(!is.genind(x)) stop("x is not a valid genind object")
-
+  if(x at ploidy != as.integer(2)) stop("not implemented for non-diploid genotypes")
   if(!require(hierfstat)) stop("hierfstat package is required. Please install it.")
   if(!require(ade4)) stop("ade4 package is required. Please install it.")
   

Modified: pkg/R/hybridize.R
===================================================================
--- pkg/R/hybridize.R	2008-06-29 15:18:31 UTC (rev 142)
+++ pkg/R/hybridize.R	2008-06-29 15:38:07 UTC (rev 143)
@@ -8,6 +8,9 @@
     ## checks
     if(!is.genind(x1)) stop("x1 is not a valid genind object")
     if(!is.genind(x2)) stop("x2 is not a valid genind object")
+    if(x1 at ploidy != as.integer(2)) stop("not implemented for non-diploid genotypes")
+    if(x2 at ploidy != as.integer(2)) stop("not implemented for non-diploid genotypes")
+    
     n <- as.integer(n)
     res.type <- match.arg(res.type)
     if(!all(x1 at loc.names==x2 at loc.names)) stop("names of markers in x1 and x2 do not correspond")

Modified: pkg/R/old2new.R
===================================================================
--- pkg/R/old2new.R	2008-06-29 15:18:31 UTC (rev 142)
+++ pkg/R/old2new.R	2008-06-29 15:38:07 UTC (rev 143)
@@ -23,6 +23,7 @@
       theoLength <- theoLength + 1
   }
   res at call <- match.call()
+  res at ploidy <- 2
 
   if(length(object) > theoLength) warning("optional content else than pop and pop.names was not converted")
 
@@ -41,7 +42,7 @@
   res at loc.fac <- as.factor(x$loc.fac)
   res at all.names <- as.list(x$all.names)
   res at call <- match.call()
-
+  
   if(length(object)>7) warning("optional content was not converted")
 
   return(res)