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

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

Author: jombart
Date: 2008-06-28 18:59:53 +0200 (Sat, 28 Jun 2008)
New Revision: 140

Modified:
   pkg/DESCRIPTION
   pkg/R/export.R
   pkg/TODO
Log:
Make sure check fails. (prevent installation)
Updated TODO.


Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION	2008-06-28 16:45:36 UTC (rev 139)
+++ pkg/DESCRIPTION	2008-06-28 16:59:53 UTC (rev 140)
@@ -9,4 +9,4 @@
 Description: Classes and functions for genetic data analysis within the multivariate framework.
 License: GPL (>=2)
 LazyLoad: yes
-Collate: classes.R auxil.R genind2genpop.R propTyped.R basicMethods.R old2new.R makefreq.R chooseCN.R dist.genpop.R export.R setAs.R gstat.randtest.R HWE.R import.R monmonier.R coords.monmonier.R spca.R spca.rtests.R zzz.R hybridize.R fstat.R propShared.R scale.R 
\ No newline at end of file
+Collate: classes.R auxil.R genind2genpop.R propTyped.R basicMethods.R old2new.R makefreq.R chooseCN.R dist.genpop.R export.R setAs.R gstat.randtest.R HWE.R import.R monmonier.R coords.monmonier.R spca.R spca.rtests.R zzz.R hybridize.R fstat.R propShared.R scale.R DONOTPASSCHECK.R
\ No newline at end of file

Modified: pkg/R/export.R
===================================================================
--- pkg/R/export.R	2008-06-28 16:45:36 UTC (rev 139)
+++ pkg/R/export.R	2008-06-28 16:59:53 UTC (rev 140)
@@ -16,6 +16,7 @@
 genind2genotype <- function(x,pop=NULL,res.type=c("matrix","list")){
 
   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 objects")
 
   if(!require(genetics)) stop("genetics package is not required but not installed.")
   if(is.null(pop)) pop <- x at pop
@@ -73,42 +74,45 @@
 # Function genind2hierfstat
 ############################
 genind2hierfstat <- function(x,pop=NULL){
-  if(!inherits(x,"genind")) stop("x must be a genind object (see ?genind)")
-  invisible(validObject(x))
-  if(is.null(pop)) pop <- x at pop
-  if(is.null(pop)) pop <- as.factor(rep("P1",nrow(x at tab)))
-  
-  # make one table by locus from x at tab
-  kX <- seploc(x,res.type="matrix")
-  # kX is a list of nloc tables
+    ##  if(!inherits(x,"genind")) stop("x must be a genind object (see ?genind)")
+    ##   invisible(validObject(x))
+    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 objects")
 
-  # prepare allele names
-  all.names <- x at all.names
+    if(is.null(pop)) pop <- x at pop
+    if(is.null(pop)) pop <- as.factor(rep("P1",nrow(x at tab)))
+    
+    ## make one table by locus from x at tab
+    kX <- seploc(x,res.type="matrix")
+    ## kX is a list of nloc tables
 
-  # check the number of first 0 to remove from all.names
-  nfirstzero <- attr(regexpr("^0*",unlist(all.names)),"match.length")
-  nrmzero <- min(nfirstzero)
+    ## prepare allele names
+    all.names <- x at all.names
 
-  for(i in 1:nrmzero) {
-    all.names <- lapply(all.names,function(e) gsub("^0","",e))
-  }
-   
-  # function to recode a genotype in form "A1A2" (as integers) from frequencies
-  recod <- function(vec,lab){
-    if(all(is.na(vec))) return(NA)
-    if(sum(vec) < 0) return(NA)
-    temp <- which(vec!=0)
-    lab <- lab[temp]
-    res <- as.integer(paste(lab[1],lab[length(lab)],sep=""))
-    return(res)
-  }
+    ## check the number of first 0 to remove from all.names
+    nfirstzero <- attr(regexpr("^0*",unlist(all.names)),"match.length")
+    nrmzero <- min(nfirstzero)
 
-  # kGen is a list of nloc vectors of genotypes
-  kGen <- lapply(1:length(kX), function(i) apply(kX[[i]],1,recod,all.names[[i]]))
-  res <- cbind(as.numeric(pop),as.data.frame(kGen))
-  colnames(res) <- c("pop",x at loc.names)
+    for(i in 1:nrmzero) {
+        all.names <- lapply(all.names,function(e) gsub("^0","",e))
+    }
+    
+    ## function to recode a genotype in form "A1A2" (as integers) from frequencies
+    recod <- function(vec,lab){
+        if(all(is.na(vec))) return(NA)
+        if(sum(vec) < 0) return(NA)
+        temp <- which(vec!=0)
+        lab <- lab[temp]
+        res <- as.integer(paste(lab[1],lab[length(lab)],sep=""))
+        return(res)
+    }
 
-  return(res)
+                                        # kGen is a list of nloc vectors of genotypes
+    kGen <- lapply(1:length(kX), function(i) apply(kX[[i]],1,recod,all.names[[i]]))
+    res <- cbind(as.numeric(pop),as.data.frame(kGen))
+    colnames(res) <- c("pop",x at loc.names)
+
+    return(res)
 }
 
 

Modified: pkg/TODO
===================================================================
--- pkg/TODO	2008-06-28 16:45:36 UTC (rev 139)
+++ pkg/TODO	2008-06-28 16:59:53 UTC (rev 140)
@@ -35,8 +35,13 @@
 # NEW IMPLEMENTATIONS:
 =====================
 * 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
+  - look for other functions to adapt
 * implement classical Fst sensu Weir 1996
 
+
 # TESTING:
 ==========
 * 
@@ -49,9 +54,9 @@
 * in spca, when nfposi=0, the returned object actually contains what corresponds to nfposi=1. Comes from multispati in ade4. To correct in ade4.
 * use spcaIllus to illustrate global.rtest and local.rtest
 * check all examples and look for possible improvements
-* Implement "sep" argument in df2genind
+* Implement "sep" argument in df2genind -- done(TJ)
 * Implement a method to merge different markers for the same individuals
-* Build accessors for marker names, indiv names, pop names, spatial coords, ...
+* Build accessors for marker names, indiv names, pop names, spatial coords, ... -- done in part (nLoc) (TJ)
 * Return a spatial object from monmonier (class sp?)