[adegenet-commits] r757 - in pkg: . R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Jan 7 15:13:00 CET 2011
Author: jombart
Date: 2011-01-07 15:12:57 +0100 (Fri, 07 Jan 2011)
New Revision: 757
Added:
pkg/R/glFunctions.R
Modified:
pkg/DESCRIPTION
pkg/R/SNPbin.R
pkg/R/handling.R
Log:
Omyfg, lots of stuff. Added plenty of new accessors for genind/genpop/SNPbin/genlight, including replacement methods. Started aux comput functions for genlight. So far, mean, nb of NAs, variance work. Doc needs completion. Next step is glPca.
Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION 2011-01-05 17:54:33 UTC (rev 756)
+++ pkg/DESCRIPTION 2011-01-07 14:12:57 UTC (rev 757)
@@ -10,6 +10,6 @@
Suggests: ade4, genetics, hierfstat, spdep, tripack, ape, pegas, graph, RBGL, seqinr
Depends: methods, MASS
Description: Classes and functions for genetic data analysis within the multivariate framework.
-Collate: classes.R basicMethods.R handling.R auxil.R setAs.R find.clust.R hybridize.R scale.R fstat.R import.R seqTrack.R chooseCN.R genind2genpop.R loadingplot.R sequences.R gstat.randtest.R makefreq.R colorplot.R monmonier.R spca.R coords.monmonier.R haploGen.R old2new.R spca.rtests.R dapc.R haploPop.R PCtest.R dist.genpop.R Hs.R propShared.R export.R HWE.R propTyped.R inbreeding.R SNPbin.R zzz.R
+Collate: classes.R basicMethods.R handling.R auxil.R setAs.R find.clust.R hybridize.R scale.R fstat.R import.R seqTrack.R chooseCN.R genind2genpop.R loadingplot.R sequences.R gstat.randtest.R makefreq.R colorplot.R monmonier.R spca.R coords.monmonier.R haploGen.R old2new.R spca.rtests.R dapc.R haploPop.R PCtest.R dist.genpop.R Hs.R propShared.R export.R HWE.R propTyped.R inbreeding.R SNPbin.R glFunctions.R zzz.R
License: GPL (>=2)
LazyLoad: yes
Modified: pkg/R/SNPbin.R
===================================================================
--- pkg/R/SNPbin.R 2011-01-05 17:54:33 UTC (rev 756)
+++ pkg/R/SNPbin.R 2011-01-07 14:12:57 UTC (rev 757)
@@ -347,59 +347,58 @@
############
## accessors
############
+
+## nLoc
setMethod("nLoc","SNPbin", function(x,...){
return(x at n.loc)
})
-
setMethod("nLoc","genlight", function(x,...){
return(x at n.loc)
})
+## nInd
setMethod("nInd","genlight", function(x,...){
return(length(x at gen))
})
+## $
setMethod("$","SNPbin",function(x,name) {
return(slot(x,name))
})
-
setMethod("$","genlight",function(x,name) {
return(slot(x,name))
})
-
setMethod("$<-","SNPbin",function(x,name,value) {
slot(x,name,check=TRUE) <- value
return(x)
})
-
setMethod("$<-","genlight",function(x,name,value) {
slot(x,name,check=TRUE) <- value
return(x)
})
+## names
setMethod("names", signature(x = "SNPbin"), function(x){
return(slotNames(x))
})
-
setMethod("names", signature(x = "genlight"), function(x){
return(slotNames(x))
})
+## ploidy
setMethod("ploidy","SNPbin", function(x,...){
return(x at ploidy)
})
-
-
setMethod("ploidy","genlight", function(x,...){
if(!is.null(x at ploidy)){
res <- x at ploidy
@@ -411,19 +410,75 @@
})
+setMethod("ploidy<-","SNPbin",function(x,value, ...) {
+ value <- as.integer(value)
+ if(any(value)<1) stop("Negative or null values provided")
+ if(any(is.na(value))) stop("NA values provided")
+ if(length(value)>1) warning("Several ploidy numbers provided; using only the first integer")
+ slot(x,"ploidy",check=TRUE) <- value[1]
+ return(x)
+})
+setMethod("ploidy<-","genlight",function(x,value, ...) {
+ value <- as.integer(value)
+ if(any(value)<1) stop("Negative or null values provided")
+ if(any(is.na(value))) stop("NA values provided")
+ if(length(value) != nInd(x)) stop("Length of the provided vector does not match nInd(x)")
+ slot(x,"ploidy",check=TRUE) <- value
+ return(x)
+})
+
+
+## locNames
setMethod("locNames","genlight", function(x,...){
return(x at loc.names)
})
+setMethod("locNames<-","genlight",function(x,value, ...) {
+ value <- as.character(value)
+ if(length(value) != nLoc(x)) stop("Vector length does no match number of loci")
+ slot(x,"loc.names",check=TRUE) <- value
+ return(x)
+})
+
+
+## indNames
setMethod("indNames","genlight", function(x,...){
return(x at ind.names)
})
+setMethod("indNames<-","genlight",function(x,value, ...) {
+ value <- as.character(value)
+ if(length(value) != nInd(x)) stop("Vector length does no match number of individuals")
+ slot(x,"ind.names",check=TRUE) <- value
+ return(x)
+})
+## allNames
+setMethod("allNames","genlight", function(x,...){
+ return(x at loc.all)
+})
+
+
+## NA.posi
+setGeneric("NA.posi", function(x, ...) standardGeneric("NA.posi"))
+
+setMethod("NA.posi","SNPbin", function(x,...){
+ return(x at NA.posi)
+})
+
+setMethod("NA.posi","genlight", function(x,...){
+ res <- lapply(x at gen, function(e) e at NA.posi)
+ names(res) <- indNames(x)
+ return(res)
+})
+
+
+
+
###############
## '[' operators
###############
Added: pkg/R/glFunctions.R
===================================================================
--- pkg/R/glFunctions.R (rev 0)
+++ pkg/R/glFunctions.R 2011-01-07 14:12:57 UTC (rev 757)
@@ -0,0 +1,105 @@
+
+##########
+## glSum
+##########
+## compute col sums
+## removing NAs
+##
+glSum <- function(x){
+ if(!inherits(x, "genlight")) stop("x is not a genlight object")
+
+ ## DEFAULT, VECTOR-WISE PROCEDURE ##
+ res <- integer(nLoc(x))
+ for(e in x at gen){
+ temp <- as.integer(e)
+ temp[is.na(temp)] <- 0L
+ res <- res + temp
+ }
+
+ names(res) <- locNames(x)
+ return(res)
+
+} # glSum
+
+
+
+
+
+##########
+## glNA
+##########
+## counts NB of NAs per column
+##
+glNA <- function(x){
+ if(!inherits(x, "genlight")) stop("x is not a genlight object")
+
+ ## DEFAULT, VECTOR-WISE PROCEDURE ##
+ res <- integer(nLoc(x))
+ temp <- NA.posi(x)
+ for(e in temp){
+ if(length(e)>0){
+ res[e] <- res[e] + 1
+ }
+ }
+
+ names(res) <- locNames(x)
+ return(res)
+
+} # glNA
+
+
+
+
+
+##########
+## glMean
+##########
+## computes SNPs means
+## takes NAs into account
+##
+glMean <- function(x){
+ if(!inherits(x, "genlight")) stop("x is not a genlight object")
+
+ ## DEFAULT, VECTOR-WISE PROCEDURE ##
+ N <- nInd(x) - glNA(x)
+ res <- glSum(x)/N
+ names(res) <- locNames(x)
+ return(res)
+
+} # glMean
+
+
+
+
+
+
+########
+## glVar
+########
+## computes SNPs variances
+## takes NAs into account
+##
+glVar <- function(x){
+ if(!inherits(x, "genlight")) stop("x is not a genlight object")
+
+ ## DEFAULT, VECTOR-WISE PROCEDURE ##
+ N <- nInd(x) - glNA(x)
+ xbar <- glMean(x)
+
+ res <- numeric(nLoc(x))
+ for(e in x at gen){
+ temp <- (as.integer(e) - xbar)^2
+ temp[is.na(temp)] <- 0L
+ res <- res + temp
+ }
+
+ res <- res/N
+ names(res) <- locNames(x)
+ return(res)
+
+} # glVar
+
+
+
+## TESTING ##
+## all.equal(glVar(x), apply(as.matrix(x), 2, function(e) mean((e-mean(e, na.rm=TRUE))^2, na.rm=TRUE)))
Modified: pkg/R/handling.R
===================================================================
--- pkg/R/handling.R 2011-01-05 17:54:33 UTC (rev 756)
+++ pkg/R/handling.R 2011-01-07 14:12:57 UTC (rev 757)
@@ -594,6 +594,9 @@
standardGeneric("locNames")
})
+setGeneric("locNames<-", function(x, value, ...) {
+ standardGeneric("locNames<-")
+})
setMethod("locNames","genind", function(x, withAlleles=FALSE, ...){
@@ -607,7 +610,15 @@
})
+setMethod("locNames<-","genind",function(x,value, ...) {
+ value <- as.character(value)
+ if(length(value) != nLoc(x)) stop("Vector length does no match number of loci")
+ names(value) <- names(locNames(x))
+ slot(x,"loc.names",check=TRUE) <- value
+ return(x)
+})
+
setMethod("locNames","genpop", function(x, withAlleles=FALSE, ...){
## return simply locus names
if(x at type=="PA" | !withAlleles) return(x at loc.names)
@@ -619,6 +630,13 @@
})
+setMethod("locNames<-","genpop",function(x,value, ...) {
+ value <- as.character(value)
+ if(length(value) != nLoc(x)) stop("Vector length does no match number of loci")
+ names(value) <- names(locNames(x))
+ slot(x,"loc.names",check=TRUE) <- value
+ return(x)
+})
###########
@@ -628,18 +646,45 @@
standardGeneric("indNames")
})
+setGeneric("indNames<-", function(x, value, ...){
+ standardGeneric("indNames<-")
+})
-
setMethod("indNames","genind", function(x, ...){
return(x at ind.names)
})
+setMethod("indNames<-","genind",function(x,value, ...) {
+ value <- as.character(value)
+ if(length(value) != nInd(x)) stop("Vector length does no match number of individuals")
+ names(value) <- names(indNames(x))
+ slot(x,"ind.names",check=TRUE) <- value
+ return(x)
+})
+##########
+# allNames
+##########
+setGeneric("allNames", function(x,...){
+ standardGeneric("allNames")
+})
+
+setMethod("allNames","genind", function(x, ...){
+ return(x at all.names)
+})
+
+setMethod("allNames","genpop", function(x, ...){
+ return(x at all.names)
+})
+
+
+
+
#######
# ploidy
#######
@@ -647,17 +692,37 @@
standardGeneric("ploidy")
})
+setGeneric("ploidy<-", function(x, value, ...){
+ standardGeneric("ploidy<-")
+})
-
setMethod("ploidy","genind", function(x,...){
return(nrow(x at ploidy))
})
+setMethod("ploidy<-","genind",function(x,value, ...) {
+ value <- as.integer(value)
+ if(any(value)<1) stop("Negative or null values provided")
+ if(any(is.na(value))) stop("NA values provided")
+ if(length(value)>1) warning("Several ploidy numbers provided; using only the first integer")
+ slot(x,"ploidy",check=TRUE) <- value[1]
+ return(x)
+})
+
setMethod("ploidy","genpop", function(x,...){
return(nrow(x at ploidy))
})
+setMethod("ploidy<-","genind",function(x,value, ...) {
+ value <- as.integer(value)
+ if(any(value)<1) stop("Negative or null values provided")
+ if(any(is.na(value))) stop("NA values provided")
+ if(length(value)>1) warning("Several ploidy numbers provided; using only the first integer")
+ slot(x,"ploidy",check=TRUE) <- value[1]
+ return(x)
+})
+
More information about the adegenet-commits
mailing list