[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