[adegenet-commits] r214 - / branches branches/devel-unstable branches/devel-unstable/R branches/devel-unstable/data branches/devel-unstable/inst branches/devel-unstable/inst/files branches/devel-unstable/man branches/devel-unstable/src

noreply at r-forge.r-project.org noreply at r-forge.r-project.org
Thu Dec 4 22:57:46 CET 2008


Author: jombart
Date: 2008-12-04 22:57:46 +0100 (Thu, 04 Dec 2008)
New Revision: 214

Added:
   branches/
   branches/devel-unstable/
   branches/devel-unstable/ChangeLog
   branches/devel-unstable/DESCRIPTION
   branches/devel-unstable/R/
   branches/devel-unstable/R/HWE.R
   branches/devel-unstable/R/auxil.R
   branches/devel-unstable/R/basicMethods.R
   branches/devel-unstable/R/chooseCN.R
   branches/devel-unstable/R/classes.R
   branches/devel-unstable/R/colorplot.R
   branches/devel-unstable/R/coords.monmonier.R
   branches/devel-unstable/R/dist.genpop.R
   branches/devel-unstable/R/export.R
   branches/devel-unstable/R/fstat.R
   branches/devel-unstable/R/genind2genpop.R
   branches/devel-unstable/R/gstat.randtest.R
   branches/devel-unstable/R/hybridize.R
   branches/devel-unstable/R/import.R
   branches/devel-unstable/R/loadingplot.R
   branches/devel-unstable/R/makefreq.R
   branches/devel-unstable/R/monmonier.R
   branches/devel-unstable/R/old2new.R
   branches/devel-unstable/R/propShared.R
   branches/devel-unstable/R/propTyped.R
   branches/devel-unstable/R/scale.R
   branches/devel-unstable/R/setAs.R
   branches/devel-unstable/R/spca.R
   branches/devel-unstable/R/spca.rtests.R
   branches/devel-unstable/R/zzz.R
   branches/devel-unstable/README
   branches/devel-unstable/TITLE
   branches/devel-unstable/TODO
   branches/devel-unstable/data/
   branches/devel-unstable/data/microbov.RData
   branches/devel-unstable/data/nancycats.RData
   branches/devel-unstable/data/rupica.RData
   branches/devel-unstable/data/sim2pop.RData
   branches/devel-unstable/data/spcaIllus.RData
   branches/devel-unstable/inst/
   branches/devel-unstable/inst/CITATION
   branches/devel-unstable/inst/files/
   branches/devel-unstable/inst/files/mondata1.rda
   branches/devel-unstable/inst/files/mondata2.rda
   branches/devel-unstable/inst/files/nancycats.dat
   branches/devel-unstable/inst/files/nancycats.gen
   branches/devel-unstable/inst/files/nancycats.gtx
   branches/devel-unstable/inst/files/nancycats.str
   branches/devel-unstable/man/
   branches/devel-unstable/man/HWE.Rd
   branches/devel-unstable/man/accessors.Rd
   branches/devel-unstable/man/adegenet.package.Rd
   branches/devel-unstable/man/as-methods.Rd
   branches/devel-unstable/man/as.genind.Rd
   branches/devel-unstable/man/as.genpop.Rd
   branches/devel-unstable/man/auxil.Rd
   branches/devel-unstable/man/chooseCN.Rd
   branches/devel-unstable/man/colorplot.Rd
   branches/devel-unstable/man/coords.monmonier.Rd
   branches/devel-unstable/man/df2genind.Rd
   branches/devel-unstable/man/dist.genpop.Rd
   branches/devel-unstable/man/export.Rd
   branches/devel-unstable/man/fstat.Rd
   branches/devel-unstable/man/genind.Rd
   branches/devel-unstable/man/genind2genpop.Rd
   branches/devel-unstable/man/genpop.Rd
   branches/devel-unstable/man/gstat.randtest.Rd
   branches/devel-unstable/man/hybridize.Rd
   branches/devel-unstable/man/import.Rd
   branches/devel-unstable/man/loadingplot.Rd
   branches/devel-unstable/man/makefreq.Rd
   branches/devel-unstable/man/microbov.Rd
   branches/devel-unstable/man/monmonier.Rd
   branches/devel-unstable/man/na.replace.Rd
   branches/devel-unstable/man/nancycats.Rd
   branches/devel-unstable/man/old2new.Rd
   branches/devel-unstable/man/propShared.Rd
   branches/devel-unstable/man/propTyped.Rd
   branches/devel-unstable/man/read.fstat.Rd
   branches/devel-unstable/man/read.genepop.Rd
   branches/devel-unstable/man/read.genetix.Rd
   branches/devel-unstable/man/read.structure.Rd
   branches/devel-unstable/man/repool.Rd
   branches/devel-unstable/man/rupica.Rd
   branches/devel-unstable/man/scale.Rd
   branches/devel-unstable/man/seploc.Rd
   branches/devel-unstable/man/seppop.Rd
   branches/devel-unstable/man/sim2pop.Rd
   branches/devel-unstable/man/spca.Rd
   branches/devel-unstable/man/spca.rtests.Rd
   branches/devel-unstable/man/spcaIllus.Rd
   branches/devel-unstable/man/truenames.Rd
   branches/devel-unstable/man/virClasses.Rd
   branches/devel-unstable/misc/
   branches/devel-unstable/src/
   branches/devel-unstable/src/adegenet.so
   branches/devel-unstable/src/adesub.c
   branches/devel-unstable/src/adesub.h
   branches/devel-unstable/src/monmonier-utils.c
   branches/devel-unstable/src/sharedAll.c
Log:
Added the bloody 'branches' directory!


Added: branches/devel-unstable/ChangeLog
===================================================================
--- branches/devel-unstable/ChangeLog	                        (rev 0)
+++ branches/devel-unstable/ChangeLog	2008-12-04 21:57:46 UTC (rev 214)
@@ -0,0 +1,173 @@
+			CHANGES IN ADEGENET VERSION 1.2-1
+
+
+NEW FEATURES
+
+	o documentation of scaleGen provides an example of usefulness of
+	an appropriate scaling in PCA
+
+BUG FIXES
+
+	o fixed the recognition of NAs in df2genind
+
+	o fixed the call to inherits in spca (returned value changes in R-devel)
+
+
+
+			CHANGES IN ADEGENET VERSION 1.2-0
+
+
+NEW FEATURES
+
+	o implement different levels of ploidy in genind / genpop
+	objects. Make necessary adaptations throughout the package.
+
+	o put some stop where needed when ploidy!=2 is not handled.
+
+	o implement a "sep" argument in df2genind.
+
+	o implement accessor for genind/genpop: nLoc.
+
+	o implement "scaleGen" for genind/genpop, which allows for
+	different types of scaling.
+
+	o added several coercion methods, from genind/genpop to
+	data.frame, matrix and ktab objects.
+
+	o implemented propTyped, a function giving the proportion of
+	non-missing data in different ways.
+
+BUG FIXES
+
+	o missing data indicated in summary corrected (loci with more
+	alleles had more weight in the computations).
+
+
+
+			CHANGES IN ADEGENET VERSION 1.1-2
+
+
+NEW FEATURES
+
+	o significant improvement in the speed of genind2df (more than
+	twice as fast as before).
+
+	o function propShared added: computes the proportion of shared
+	alleles among a set of genotypes (core computations in C).
+
+	o A warning is issued when NAs exist in the input of sPCA.
+
+	o improvement of the validity checking for genind/genpop:
+	validObject now detects duplicates in any kind of names (ind.names,
+	pop.names, etc.) and prints the corresponding items.
+
+
+
+BUG FIXES
+
+	o genind2df does now handles the pop argument correctly.
+
+	o df2genind does no longer bug when there is an entirely non-typed
+	locus.
+
+
+
+			CHANGES IN ADEGENET VERSION 1.1-1
+
+
+NEW FEATURES
+
+	o I/O: df2genind no longer fails when entirely non-type
+	individuals exist.
+
+	o Monmonier: optimize.monmonier now computes the 'best'
+	boundary only once instead of twice. The whole code was re-thought
+	and optimized for speed. Monmonier's boundaries can now form
+	loops. Instead of stoping at a given threshold, it is also
+	possible to ask for a given length of boundary (argument
+	bd.length).
+
+	o The function chooseCN has a new option to return a list of
+	spatial weights defined as the inverse of spatial distances, at a
+	given exponent.
+
+	o A wrapper for glob.varcomp has been implemented for genind
+	objects, through the new function fstat.
+
+	o The elements of the @other slot are now proceeded wisely when
+	objects are subsetted using the '[' operator.
+
+
+BUG FIXES
+
+	o I/O: df2genind no longer fails when entirely non-type
+	individuals exist.
+
+	o monmonier no longer fails when coordinates are drawn from a
+	regular grid. The matched call of the returned object has been
+	fixed.
+
+
+
+			CHANGES IN ADEGENET VERSION 1.1-0
+
+NEW FEATURES
+	o Data representation: S4 classes in replacement of old S3
+	classes.
+
+	o Spatial genetics: the spatial Principal Component Analysis
+	(Jombart et al, 2008, Heredity), two multivariate spatial
+	tests, and new functionalities for Monmonier's algorithm.
+
+	o I/O: functions to import data are now 'read' functions;
+	available for formats of GENETIX, Fstat, Genepop, STRUCTURE and
+	from data.frames of genotypes. Export from genind to data.frame of
+	genotypes.
+
+	o Data: five new simulated geo-referenced datasets
+
+	o Simulations: a hybridize function, which creates hybrids from
+	two parent datasets. Can output to STRUCTURE format.
+
+	o Data manipulation: new function to separate data by
+	population. Accessors to genind and genpop object like with
+	matrices using 'foo[ chosenGenotypes, chosenAlleles]'.
+
+
+
+			CHANGES IN ADEGENET VERSION 1.0-2
+
+NEW FEATURES
+
+	o adegenetWeb is a simple function opening the adegenet website in
+	the default web browser.
+
+	o sim2pop is a dataset obtained by simulation using the software
+	Easypop. It contains 130 georeferenced genotypes sampled from two
+	distinct populations.
+
+	o monmonier documentation was improved by adding a genetic
+	example, using sim2pop data.
+
+BUG FIXES
+
+	o some bugs corrected in optimize.monmonier
+
+
+			CHANGES IN ADEGENET VERSION 1.0-1
+
+NEW FEATURES
+
+	o chooseCN is a simple interactive tool for choosing and building
+	a connection network from spatial coordinates. This tool is called
+	by monmonier function.
+
+	o monmonier, optimize.monmonier, plot.monmonier and print.monmonier
+	implement the Monmonier algorithm. While not restrained to genetic
+	data analysis, this method can be used to find genetic boundaries
+	among individuals or populations based on their allelic
+	frequencies and spatial coordinates. 
+
+BUG FIXES
+
+	o several bugs fixed in I/O functions

Added: branches/devel-unstable/DESCRIPTION
===================================================================
--- branches/devel-unstable/DESCRIPTION	                        (rev 0)
+++ branches/devel-unstable/DESCRIPTION	2008-12-04 21:57:46 UTC (rev 214)
@@ -0,0 +1,12 @@
+Package: adegenet
+Version: 1.2-2
+Date: 2008/07/30
+Title: adegenet: a R package for the multivariate analysis of genetic markers.
+Author: Thibaut Jombart <jombart at biomserv.univ-lyon1.fr>, with contributions from Peter Solymos
+Maintainer: Thibaut Jombart <jombart at biomserv.univ-lyon1.fr>
+Suggests: ade4, genetics, hierfstat, spdep, tripack
+Depends: methods
+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 colorplot.R loadingplot.R

Added: branches/devel-unstable/R/HWE.R
===================================================================
--- branches/devel-unstable/R/HWE.R	                        (rev 0)
+++ branches/devel-unstable/R/HWE.R	2008-12-04 21:57:46 UTC (rev 214)
@@ -0,0 +1,51 @@
+##################
+# HWE.test.genind
+##################
+
+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)))
+  res.type <- tolower(res.type[1])
+  if(res.type != "full" && res.type != "matrix") stop("unknown res.type specified.")
+  
+  kGen <- genind2genotype(x,pop=pop,res.type="list")
+  
+  # ftest tests HWE for a locus and a population
+  ftest <- function(vec,permut=permut,nperm=nsim){
+    temp <- unique(vec)
+    temp <- temp[!is.na(temp)]
+    if(length(temp) < 2) return(NA)
+    if(res.type=="full") {
+      res <- HWE.chisq(vec, simulate.p.value=permut, B=nperm)
+    } else {
+      res <- HWE.chisq(genotype(vec), simulate.p.value=permut, B=nperm)$p.value
+    }
+    return(res)
+  }
+  
+  res <- lapply(kGen,function(e) lapply(e,ftest,permut,nsim))
+
+  # clean non-tested elements in the results list
+  if(hide.NA && res.type=="full"){
+    newres=list()
+    tokeep <- which(unlist(lapply(res,function(e) !all(is.na(e)))))
+    if(length(tokeep) > 0) for(i in 1:length(tokeep)) {newres[[i]] <- res[[tokeep[i]]]}
+    newres <- lapply(newres,function(e) {e[!is.na(e)] })
+    names(newres) <- names(res)[tokeep]
+    res <- newres
+  }
+
+  if(res.type=="matrix"){
+    res <- as.data.frame(lapply(res,unlist))
+    rnam <- rownames(res)
+    rownames(res) <- gsub(".X-squared","",rnam)
+    res <- as.matrix(res)
+  }
+  
+  return(res)  
+}

Added: branches/devel-unstable/R/auxil.R
===================================================================
--- branches/devel-unstable/R/auxil.R	                        (rev 0)
+++ branches/devel-unstable/R/auxil.R	2008-12-04 21:57:46 UTC (rev 214)
@@ -0,0 +1,527 @@
+###########################
+#
+# Auxiliary functions for
+# adegenet objects
+#
+# T. Jombart
+###########################
+
+
+##############################
+# Method truenames for genind
+##############################
+setGeneric("truenames", function(x) standardGeneric("truenames"))
+
+setMethod("truenames", signature(x="genind"), function(x){
+  
+  X <- x at tab
+  if(!all(x at ind.names=="")) {rownames(X) <- x at ind.names}
+
+  labcol <- rep(x at loc.names,x at loc.nall)
+  labcol <- paste(labcol,unlist(x at all.names),sep=".")
+  colnames(X) <- labcol
+
+  if(!is.null(x at pop)){
+    pop <- x at pop
+    levels(pop) <- x at pop.names
+    return(list(tab=X,pop=pop))
+  }
+
+  return(X)
+}
+)
+
+
+
+
+
+##############################
+# Method truenames for genpop
+##############################
+setMethod("truenames",signature(x="genpop"), function(x){
+
+  X <- x at tab
+  if(!all(x at pop.names=="")) {rownames(X) <- x at pop.names}
+
+  labcol <- rep(x at loc.names,x at loc.nall)
+  labcol <- paste(labcol,unlist(x at all.names),sep=".")
+  colnames(X) <- labcol
+
+  return(X)
+})
+
+
+
+
+###########################
+# Method seploc for genind
+###########################
+setGeneric("seploc", function(x, ...) standardGeneric("seploc"))
+
+setMethod("seploc", signature(x="genind"), function(x,truenames=TRUE,res.type=c("genind","matrix")){
+  
+  if(!is.genind(x)) stop("x is not a valid genind object")
+  res.type <- match.arg(res.type)
+  if(res.type=="genind") { truenames <- TRUE }
+  
+  temp <- x at loc.fac
+  nloc <- length(levels(temp))
+  levels(temp) <- 1:nloc
+
+  kX <- list()
+  
+  for(i in 1:nloc){
+    kX[[i]] <- matrix(x at tab[,temp==i],ncol=x at loc.nall[i])
+
+    if(!truenames){
+      rownames(kX[[i]]) <- rownames(x at tab)
+      colnames(kX[[i]]) <- paste(names(x at loc.names)[i],names(x at all.names[[i]]),sep=".")
+    }else{
+      rownames(kX[[i]]) <- x at ind.names
+      colnames(kX[[i]]) <- paste(x at loc.names[i],x at all.names[[i]],sep=".")
+    }
+  }
+
+  if(truenames) {
+    names(kX) <- x at loc.names
+  } else{
+    names(kX) <- names(x at loc.names)
+  }
+
+  prevcall <- match.call()
+  if(res.type=="genind"){
+      kX <- lapply(kX, genind, pop=x at pop, prevcall=prevcall)
+      for(i in 1:length(kX)){
+          kX[[i]]@other <- x at other
+      }
+  }
+  
+  return(kX)  
+})
+
+
+
+###########################
+# Method seploc for genpop
+###########################
+setMethod("seploc", signature(x="genpop"), function(x,truenames=TRUE,res.type=c("genpop","matrix")){
+  
+  if(!is.genpop(x)) stop("x is not a valid genpop object")
+  res.type <- match.arg(res.type)
+  if(res.type=="genpop") { truenames <- TRUE }
+ 
+  temp <- x at loc.fac
+  nloc <- length(levels(temp))
+  levels(temp) <- 1:nloc
+
+  kX <- list()
+  
+  for(i in 1:nloc){
+    kX[[i]] <- matrix(x at tab[,temp==i],ncol=x at loc.nall[i])
+
+    if(!truenames){
+      rownames(kX[[i]]) <- rownames(x at tab)
+      colnames(kX[[i]]) <- paste(names(x at loc.names)[i],names(x at all.names[[i]]),sep=".")
+    }else{
+      rownames(kX[[i]]) <- x at pop.names
+      colnames(kX[[i]]) <- paste(x at loc.names[i],x at all.names[[i]],sep=".")
+    }
+  }
+
+  if(truenames) {
+    names(kX) <- x at loc.names
+  } else{
+    names(kX) <- names(x at loc.names)
+  }
+
+  prevcall <- match.call()
+  if(res.type=="genpop"){
+      kX <- lapply(kX, genpop, prevcall=prevcall)
+      for(i in 1:length(kX)){
+          kX[[i]]@other <- x at other
+      }
+  }
+
+  return(kX)  
+})
+
+
+
+
+#######################
+# Function adegenetWeb
+#######################
+adegenetWeb <- function(){
+    cat("Opening url \"http://adegenet.r-forge.r-project.org/\" ...\n")
+    browseURL("http://adegenet.r-forge.r-project.org/")
+}
+
+
+
+
+############################
+# Function adegenetTutorial
+############################
+adegenetTutorial <- function(which=c("general","spca")){
+    which <- match.arg(which)
+    if(which=="general"){
+        url <- "http://adegenet.r-forge.r-project.org/files/adegenet.pdf"
+        cat("\n")
+        cat("  >> Seeking the general tutorial for adegenet.\n")
+        cat("  >> Opening url \"",url,"\".\n ", sep="")
+        cat("\n")
+        browseURL(url)
+    }
+    if(which=="spca"){
+        url <- "http://adegenet.r-forge.r-project.org/files/tutorial-spca.pdf"
+        cat("\n")
+        cat("  >> Seeking the sPCA tutorial for adegenet.\n")
+        cat("  >> Opening url \"",url,"\". \n", sep="")
+        cat("\n")
+        browseURL(url)
+    }
+}
+
+
+
+
+###############
+# '$' operator
+###############
+setMethod("$","genind",function(x,name) {
+    return(slot(x,name))
+})
+
+
+setMethod("$<-","genind",function(x,name,value) {
+   slot(x,name,check=TRUE) <- value
+  return(x)
+})
+
+
+setMethod("$","genpop",function(x,name) {
+    return(slot(x,name))
+})
+
+
+setMethod("$<-","genpop",function(x,name,value) {
+  slot(x,name,check=TRUE) <- value
+  return(x)
+})
+
+
+
+
+
+###############
+# '[' operator
+###############
+## genind
+setMethod("[","genind",
+          function(x, i, j, ..., loc=NULL, treatOther=TRUE, drop=FALSE) {
+
+              if (missing(i)) i <- TRUE
+              if (missing(j)) j <- TRUE
+
+              pop <- NULL
+              if(is.null(x at pop)) { tab <- truenames(x) }
+              if(!is.null(x at pop)) {
+                  temp <- truenames(x)
+                  tab <- temp$tab
+                  pop <- temp$pop
+                  pop <- factor(pop[i])
+              }
+
+              ## handle loc argument
+              if(!is.null(loc)){
+                  loc <- as.character(loc)
+                  temp <- !loc %in% x at loc.fac
+                  if(any(temp)) { # si mauvais loci
+                      warning(paste("the following specified loci do not exist:", loc[temp]))
+                  }
+                  j <- x$loc.fac %in% loc
+              } # end loc argument
+              
+              prevcall <- match.call()
+              tab <- tab[i, j, ...,drop=FALSE]
+              
+              res <- genind(tab,pop=pop,prevcall=prevcall)
+
+              ## handle 'other' slot
+              nOther <- length(x at other)
+              namesOther <- names(x at other)
+              counter <- 0
+              if(treatOther){
+                  f1 <- function(obj,n=nrow(x at tab)){
+                      counter <<- counter+1
+                      if(!is.null(dim(obj)) && nrow(obj)==n) { # if the element is a matrix-like obj
+                          obj <- obj[i,,drop=FALSE]
+                      } else if(length(obj) == n) { # if the element is not a matrix but has a length == n
+                          obj <- obj[i]
+                          if(is.factor(obj)) {obj <- factor(obj)}
+                      } else {warning(paste("cannot treat the object",namesOther[counter]))}
+
+                      return(obj)
+                  } # end f1
+
+                  res at other <- lapply(x at other, f1) # treat all elements
+                  
+              } # end treatOther
+              
+              return(res)
+          })
+
+
+## genpop
+setMethod("[","genpop", 
+          function(x, i, j, ..., loc=NULL, treatOther=TRUE, drop=FALSE) {
+
+              if (missing(i)) i <- TRUE
+              if (missing(j)) j <- TRUE
+
+              tab <- truenames(x) 
+
+              ## handle loc argument
+              if(!is.null(loc)){
+                  loc <- as.character(loc)
+                  temp <- !loc %in% x at loc.fac
+                  if(any(temp)) { # si mauvais loci
+                      warning(paste("the following specified loci do not exist:", loc[temp]))
+                  }
+                  j <- x$loc.fac %in% loc
+              } # end loc argument
+
+              prevcall <- match.call()
+              tab <- tab[i, j, ...,drop=FALSE]
+              
+              res <- genpop(tab,prevcall=prevcall)
+
+              ## handle 'other' slot
+              nOther <- length(x at other)
+              namesOther <- names(x at other)
+              counter <- 0
+              if(treatOther){
+                  f1 <- function(obj,n=nrow(x at tab)){
+                      counter <<- counter+1
+                      if(!is.null(dim(obj)) && nrow(obj)==n) { # if the element is a matrix-like obj
+                          obj <- obj[i,,drop=FALSE]
+                      } else if(length(obj) == n) { # if the element is not a matrix but has a length == n
+                          obj <- obj[i]
+                          if(is.factor(obj)) {obj <- factor(obj)}
+                      } else {warning(paste("cannot treat the object",namesOther[counter]))}
+                      
+                      return(obj)
+                  } # end f1
+                  
+                  res at other <- lapply(x at other, f1) # treat all elements
+                  
+              } # end treatOther
+             
+              
+              return(res)
+          })
+
+
+
+
+
+
+##################
+# Function seppop
+##################
+setGeneric("seppop", function(x, ...) standardGeneric("seppop"))
+
+## genind
+setMethod("seppop", signature(x="genind"), function(x,pop=NULL,truenames=TRUE,res.type=c("genind","matrix")){
+
+    ## misc checks 
+    if(!is.genind(x)) stop("x is not a valid genind object")
+    if(is.null(pop)) {pop <- x at pop}
+    if(is.null(pop)) stop("pop not provided and x at pop is empty")
+    res.type <- match.arg(res.type)
+    if(res.type=="genind") { truenames <- TRUE }
+  
+    pop <- x at pop
+    levels(pop) <- x at pop.names
+
+    ## make a list of genind objects
+    kObj <- lapply(levels(pop), function(lev) x[pop==lev, ])
+    names(kObj) <- levels(pop)
+
+    ## res is a list of genind
+    if(res.type=="genind"){ return(kObj) }
+  
+    ## res is list of matrices
+    if(truenames) {
+        res <- lapply(kObj, function(obj) truenames(obj)$tab)
+    } else{
+        res <- lapply(kObj, function(obj) obj$tab)
+    }
+    
+    return(res) 
+}) # end seppop
+
+
+
+
+
+#####################
+# Methods na.replace
+#####################
+setGeneric("na.replace", function(x, ...) standardGeneric("na.replace"))
+
+## genind method
+setMethod("na.replace", signature(x="genind"), function(x,method, quiet=FALSE){
+
+    ## preliminary stuff
+    validObject(x)
+    if(!any(is.na(x at tab))) {
+        if(!quiet) cat("\n Replaced 0 missing values \n")
+        return(x)
+    }
+    method <- tolower(method)
+    method <- match.arg(method, c("0","mean"))
+
+    res <- x
+    
+    if(method=="0"){
+        res at tab[is.na(x at tab)] <- 0
+    }
+
+    if(method=="mean"){
+        f1 <- function(vec){
+            m <- mean(vec,na.rm=TRUE)
+            vec[is.na(vec)] <- m
+            return(vec)
+        }
+
+        res at tab <- apply(x at tab, 2, f1)
+    }
+
+    if(!quiet){
+        Nna <- sum(is.na(x at tab))
+        cat("\n Replaced",Nna,"missing values \n")
+    }
+
+    return(res)
+
+})
+
+
+
+
+## genpop method
+setMethod("na.replace", signature(x="genpop"), function(x,method, quiet=FALSE){
+
+    ## preliminary stuff
+    validObject(x)
+    if(!any(is.na(x at tab))) {
+        if(!quiet) cat("\n Replaced 0 missing values \n")
+        return(x)
+    }
+
+    method <- tolower(method)
+    method <- match.arg(method, c("0","chi2"))
+
+    res <- x
+    
+    if(method=="0"){
+        res at tab[is.na(x at tab)] <- 0
+    }
+
+    if(method=="chi2"){
+        ## compute theoretical counts
+        ## (same as in a Chi-squared)
+        X <- x at tab
+        sumPop <- apply(X,1,sum,na.rm=TRUE)
+        sumLoc <- apply(X,2,sum,na.rm=TRUE)
+        X.theo <- sumPop %o% sumLoc / sum(X,na.rm=TRUE)
+
+        X[is.na(X)] <- X.theo[is.na(X)]
+        res at tab <- X
+    }
+
+    if(!quiet){
+        Nna <- sum(is.na(x at tab))
+        cat("\n Replaced",Nna,"missing values \n")
+    }
+
+    return(res)
+})
+
+
+
+
+
+##################
+# Function repool
+##################
+repool <- function(...){
+
+    ## preliminary stuff
+    x <- list(...)
+    if(is.list(x[[1]])) x <- x[[1]] ## if ... is a list, keep this list for x
+    if(!inherits(x,"list")) stop("x must be a list")
+    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){
+        if(is.null(obj$pop)) return(factor(rep(NA,nrow(obj$tab))))
+      pop <- obj$pop
+        levels(pop) <- obj$pop.names
+        return(pop)
+    }
+    
+    ## handle pop
+    listPop <- lapply(x, getPop)
+    pop <- unlist(listPop, use.name=FALSE)
+    pop <- factor(pop)
+    
+  ## handle genotypes
+    markNames <- colnames(listTab[[1]])
+    listTab <- lapply(listTab, function(tab) tab[,markNames]) # resorting of the tabs
+    
+    ## bind all tabs by rows
+    tab <- listTab[[1]] 
+    for(i in 2:length(x)){
+        tab <- rbind(tab,listTab[[i]])
+    }
+    
+    res <- df2genind(tab,pop=pop)
+    res$call <- match.call()
+    
+    return(res)
+} # end repool
+
+
+
+
+######################
+## miscellanous utils
+######################
+
+
+#######
+# nLoc
+#######
+setGeneric("nLoc", function(x,...){
+    standardGeneric("nLoc")
+})
+
+
+
+setMethod("nLoc","genind", function(x,...){
+    return(length(x at loc.names))
+})
+
+
+
+setMethod("nLoc","genpop", function(x,...){
+    return(length(x at loc.names))
+})
+

Added: branches/devel-unstable/R/basicMethods.R
===================================================================
--- branches/devel-unstable/R/basicMethods.R	                        (rev 0)
+++ branches/devel-unstable/R/basicMethods.R	2008-12-04 21:57:46 UTC (rev 214)
@@ -0,0 +1,238 @@
+##########################
+# Method show for genind
+##########################
+setMethod ("show", "genind", function(object){
+  x <- object
+  cat("\n")
+  cat("   #####################\n")
+  cat("   ### Genind object ### \n")
+  cat("   #####################")
+  cat("\n- genotypes of individuals - \n")
+  cat("\nS4 class: ", as.character(class(x)))
+
+  cat("\n at call: ")
+  print(x at call)
+
+  p <- ncol(x at tab)
+  len <- 7
+
+  cat("\n at tab: ", nrow(x at tab), "x", ncol(x at tab), "matrix of genotypes\n" )
+
+  cat("\n at ind.names: vector of ", length(x at ind.names), "individual names")
+  cat("\n at loc.names: vector of ", length(x at loc.names), "locus names")
+  cat("\n at loc.nall: number of alleles per locus")
+  cat("\n at loc.fac: locus factor for the ", ncol(x at tab), "columns of @tab")
+  cat("\n at all.names: list of ", length(x at all.names), "components yielding allele names for each locus")
+  cat("\n at ploidy: ",x at ploidy)
+  cat("\n at type: ",x at type)
+
+  cat("\n\nOptionnal contents: ")
+  cat("\n at pop: ", ifelse(is.null(x at pop), "- empty -", "factor giving the population of each individual"))
+  cat("\n at pop.names: ", ifelse(is.null(x at pop.names), "- empty -", "factor giving the population of each individual"))
+
+  cat("\n\n at other: ")
+  if(!is.null(x at other)){
+    cat("a list containing: ")
+    cat(ifelse(is.null(names(x at other)), "elements without names", paste(names(x at other), collapse= "  ")), "\n")
+  } else {
+    cat("- empty -\n")
+  }
+
+  cat("\n")
+}
+) # end show method for genind
+
+
+
+
+##########################
+# Method show for genpop
+##########################
+setMethod ("show", "genpop", function(object){
+  x <- object
+  cat("\n")
+  cat("       #####################\n")
+  cat("       ### Genpop object ### \n")
+  cat("       #####################")
+  cat("\n- Alleles counts for populations - \n")
+  cat("\nS4 class: ", as.character(class(x)))
+
+  cat("\n at call: ")
+  print(x at call)
+
+  p <- ncol(x at tab)
+
+  cat("\n at tab: ", nrow(x at tab), "x", ncol(x at tab), "matrix of alleles counts\n" )
+
+  cat("\n at pop.names: vector of ", length(x at pop.names), "population names")
+  cat("\n at loc.names: vector of ", length(x at loc.names), "locus names")
+  cat("\n at loc.nall: number of alleles per locus")
+  cat("\n at loc.fac: locus factor for the ", ncol(x at tab), "columns of @tab")
+  cat("\n at all.names: list of ", length(x at all.names), "components yielding allele names for each locus")
+  cat("\n at ploidy: ",x at ploidy)
+  cat("\n at type: ",x at type)
+
+  cat("\n\n at other: ")
+  if(!is.null(x at other)){
+    cat("a list containing: ")
+    cat(ifelse(is.null(names(x at other)), "elements without names", paste(names(x at other), collapse= "  ")), "\n")
+  } else {
+    cat("- empty -\n")
+  }
+
+  cat("\n")
+
+}
+) # end show method for genpop
+
+
+
+
+
+############################
+# Method summary for genind
+############################
+setMethod ("summary", "genind", function(object, ...){
+  x <- object
+  if(!inherits(x,"genind")) stop("To be used with a genind object")
+  if(is.null(x at pop)){
+    x at pop <- factor(rep(1,nrow(x at tab)))
+    x at pop.names <- ""
+    names(x at pop.names) <- "P1"
+  }
+
+  res <- list()
+
+  res$N <- nrow(x at tab)
+
+  res$pop.eff <- as.numeric(table(x at pop))
+  names(res$pop.eff) <- names(x at pop.names)
+
+  res$loc.nall <- x at loc.nall
+
+  temp <- genind2genpop(x,quiet=TRUE)@tab
+
+  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)) <- wrong
+  res$NA.perc <- 100*(1-mean(propTyped(x,by="both")))
+
+  ## handle heterozygosity
+  if(x at ploidy > 1){
+      ## auxiliary function to compute observed heterozygosity
+      temp <- seploc(x,truenames=FALSE,res.type="matrix")
+      f1 <- function(tab){
+          H <- apply(tab, 1, function(vec) any(vec > 0 & vec < 1))
+          H <- mean(H,na.rm=TRUE)
+          return(H)
+      }
+
+      res$Hobs <- unlist(lapply(temp,f1))
+
+      ## auxiliary function to compute expected heterozygosity
+      ## freq is a vector of frequencies
+      f2 <- function(freq){
+          H <- 1-sum(freq*freq,na.rm=TRUE)
+          return(H)
+      }
+
+      temp <- genind2genpop(x,pop=rep(1,nrow(x at tab)),quiet=TRUE)
+      temp <- makefreq(temp,quiet=TRUE)$tab
+      temp.names <- colnames(temp)
+      temp <- as.vector(temp)
+      names(temp) <- temp.names
+      temp <- split(temp,x at loc.fac)
+      ## temp is a list of alleles frequencies (one element per locus)
+
+      res$Hexp <- unlist(lapply(temp,f2))
+  } else { # no possible heterozygosity for haploid genotypes
+      res$Hobs <- 0
+      res$Xexp <- 0
+  }
+
+  ## print to screen
+  listlab <- c("# Total number of genotypes: ",
+               "# Population sample sizes: ",
+               "# Number of alleles per locus: ",
+               "# Number of alleles per population: ",
+               "# Percentage of missing data: ",
+               "# Observed heterozygosity: ",
+               "# Expected heterozygosity: ")
+  cat("\n",listlab[1],res[[1]],"\n")
+  for(i in 2:7){
+    cat("\n",listlab[i],"\n")
+    print(res[[i]])
+  }
+
+  return(invisible(res))
+}) # end summary.genind
+
+
+
+
+
+############################
+# Method summary for genpop
+############################
+setMethod ("summary", "genpop", function(object, ...){
+  x <- object
+  if(!inherits(x,"genpop")) stop("To be used with a genpop object")
+
+  res <- list()
+
+  res$npop <- nrow(x at tab)
+
+  res$loc.nall <- x at loc.nall
+
+  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)) <- 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: ",
+               "# Number of alleles per locus: ",
+               "# Number of alleles per population: ",
+               "# Percentage of missing data: ")
+  cat("\n",listlab[1],res[[1]],"\n")
+  for(i in 2:4){
+    cat("\n",listlab[i],"\n")
+    print(res[[i]])
+  }
+
+  return(invisible(res))
+
+}
+)# end summary.genpop
+
+
+
+#} # end .initAdegenetClasses()
+
+
+
+
+
+
+###############
+# Methods "is"
+###############
+is.genind <- function(x){
+  res <- ( is(x, "genind") & validObject(x))
+  return(res)
+}
+
+is.genpop <- function(x){
+  res <- ( is(x, "genpop") & validObject(x))
+  return(res)
+}
+

Added: branches/devel-unstable/R/chooseCN.R
===================================================================
--- branches/devel-unstable/R/chooseCN.R	                        (rev 0)
+++ branches/devel-unstable/R/chooseCN.R	2008-12-04 21:57:46 UTC (rev 214)
@@ -0,0 +1,207 @@
+#####################
+# Function chooseCN
+#####################
+chooseCN <- function(xy,ask=TRUE, type=NULL, result.type="nb", d1=NULL, d2=NULL, k=NULL,
+                     a=NULL, dmin=NULL, plot.nb=TRUE, edit.nb=FALSE){
+  
+  if(is.data.frame(xy)) xy <- as.matrix(xy)
+  if(ncol(xy) != 2) stop("xy does not have two columns.")
+  if(any(is.na(xy))) stop("NA entries in xy.")
+  result.type <- tolower(result.type)
+  
+  if(!require(spdep, quiet=TRUE)) stop("spdep library is required.")
+
+  res <- list()
+  
+  if(!is.null(d2)){
+      if(d2=="dmin"){
+          tempmat <- as.matrix(dist(xy))
+          d2min <- max(apply(tempmat, 1, function(r) min(r[r>1e-12])))
+          d2min <- d2min * 1.0001 # to avoid exact number problem
+          d2 <- d2min
+      } else if(d2=="dmax"){
+          d2max <- max(dist(xy))
+          d2max <- d2max * 1.0001 # to avoid exact number problem
+          d2 <- d2max
+      }
+  } # end handle d2
+  
+  d1.first <- d1
+  d2.first <- d2
+  k.first <- k
+
+  ## handle type argument
+  if(!is.null(type)){
+      type <- as.integer(type)
+      if(type < 1 |type > 7) stop("type must be between 1 and 7")
+      ask <- FALSE
+  }
+
+  ## check for uniqueness of coordinates
+  x <- xy[,1]
+  y <- xy[,2]
+  temp <- table(x,y)
+  if(any(temp>1) & (!is.null(type) && !type %in% c(5,7))){ # coords need not be unique if type==5 or 7
+      xy <- jitter(xy)
+      warning("Random noise was added to xy as duplicated coordinates existed.")
+  }
+
+  
+  if(is.null(type) & !ask) { type <- 1 }
+  
+  ### begin large while ###
+  chooseAgain <- TRUE
+  while(chooseAgain){
+    # re-initialisation of some variables
+    d1 <- d1.first
+    d2 <- d2.first
+    k <- k.first    
+    
+  ## read type from console
+    if(ask){
+      temp <- TRUE
+      while(temp){
+        cat("\nChoose a connection network:\n")
+        cat("\t Delaunay triangulation (type 1)\n")
+        cat("\t Gabriel graph (type 2)\n")
+        cat("\t Relative neighbours (type 3)\n")
+        cat("\t Minimum spanning tree (type 4)\n")
+        cat("\t Neighbourhood by distance (type 5)\n")
+        cat("\t K nearest neighbours (type 6)\n")
+        cat("\t Inverse distances (type 7)\n")
+        cat("Answer: ")
+        
+        type <- as.integer(readLines(n = 1))
+        temp <- type < 1 |type > 7
+        if(temp) cat("\nWrong answer\n")
+      } # end while
+    }
+    ## 
+    
+    ## graph types
+    ## type 1: Delaunay
+    if(type==1){
+      if(!require(tripack, quiet=TRUE)) stop("tripack library is required.")
+      cn <- tri2nb(xy)
+    }
+    
+    # type 2: Gabriel
+    if(type==2){
+      cn <- gabrielneigh(xy)
+      cn <- graph2nb(cn, sym=TRUE)
+    }
+    
+    ## type 3: Relative neighbours
+    if(type==3){
+      cn <- relativeneigh(xy)
+      cn <- graph2nb(cn, sym=TRUE)
+    }
+  
+    ## type 4: Minimum spanning tree
+    if(type==4){
+      if(!require(ade4, quiet=TRUE)) stop("ade4 library is required.")
+      cn <- mstree(dist(xy))
+      cn <- neig2nb(cn)
+    }
+  
+    ## type 5: Neighbourhood by distance
+    if(type==5){
+      if(is.null(d1) |is.null(d2)){
+        tempmat <- as.matrix(dist(xy))
+        d2min <- max(apply(tempmat, 1, function(r) min(r[r>1e-12])))
+        d2min <- d2min * 1.0001 # to avoid exact number problem
+        d2max <- max(dist(xy))
+        d2max <- d2max * 1.0001 # to avoid exact number problem
+        dig <- options("digits")
+        options("digits=5")
+        cat("\n Enter minimum distance: ")
+        d1 <- as.numeric(readLines(n = 1))
+        cat("\n Enter maximum distance \n(dmin=", d2min, ", dmax=", d2max, "): ")
+        d2 <- readLines(n = 1)
+        ## handle character
+        if(d2=="dmin") {
+            d2 <- d2min
+        } else if(d2=="dmax") {
+            d2 <- d2max
+        } else {
+            d2 <- as.numeric(d2)
+        }
+        ## restore initial digit option
+        options(dig)
+      }
+    # avoid that a point is its neighbour
+      dmin <- mean(dist(xy))/100000
+      if(d1<dmin) d1 <- dmin
+      if(d2<d1) stop("d2 < d1")
+      cn <- dnearneigh(x=xy, d1=d1, d2=d2)
+    }
+  
+    ## type 6: K nearests
+    if(type==6){
+      if(is.null(k)) {
+        cat("\n Enter the number of neighbours: ")
+        k <- as.numeric(readLines(n = 1))
+      }
+      cn <- knearneigh(x=xy, k=k)
+      cn <- knn2nb(cn, sym=TRUE)
+    }
+    
+    ## type 7: inverse distances
+    if(type==7){
+        if(is.null(a)) {
+            cat("\n Enter the exponent: ")
+            a <- as.numeric(readLines(n = 1))
+        }
+        cn <- as.matrix(dist(xy))
+        if(is.null(dmin)) {
+            cat("\n Enter the minimum distance \n(range = 0 -", max(cn),"): ")
+            dmin <- as.numeric(readLines(n = 1))
+        }
+        if(a<1) { a <- 1 }
[TRUNCATED]

To get the complete diff run:
    svnlook diff /svnroot/adegenet -r 214


More information about the adegenet-commits mailing list