[adegenet-commits] r132 - pkg/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Jun 25 18:36:12 CEST 2008
Author: jombart
Date: 2008-06-25 18:36:11 +0200 (Wed, 25 Jun 2008)
New Revision: 132
Added:
pkg/R/scale.R
Removed:
pkg/R/normalize.R
Modified:
pkg/R/classes.R
pkg/R/fstat.R
Log:
renamed normalize to scaleGen
Modified: pkg/R/classes.R
===================================================================
--- pkg/R/classes.R 2008-06-25 12:39:32 UTC (rev 131)
+++ pkg/R/classes.R 2008-06-25 16:36:11 UTC (rev 132)
@@ -134,10 +134,11 @@
# virtual class indInfo
########################
setClass("indInfo", representation(ind.names = "character",
- pop = "factorOrNULL",
- pop.names = "charOrNULL",
- other = "listOrNULL", "VIRTUAL"),
- prototype(pop=NULL, pop.names = NULL, other = NULL))
+ pop = "factorOrNULL",
+ pop.names = "charOrNULL",
+ ploidy = "integer",
+ other = "listOrNULL", "VIRTUAL"),
+ prototype(pop=NULL, pop.names = NULL, ploidy = as.integer(2), other = NULL))
@@ -159,7 +160,7 @@
warning("\nduplicate names in ind.names:\n")
print(temp[temp>1])
}
-
+
if(!is.null(object at pop)){ # check pop
if(length(object at pop) != nrow(object at tab)) {
@@ -185,6 +186,12 @@
} # end check pop
+ ## check ploidy
+ if(object at ploidy < as.integer(1)){
+ cat("\nploidy inferior to 1\n")
+ return(FALSE)
+ }
+
return(TRUE)
} #end .genind.valid
@@ -241,13 +248,11 @@
# Function names
#################
setMethod("names", signature(x = "genind"), function(x){
- temp <- rev(names(attributes(x)))[-1]
- return(rev(temp))
+ return(slotNames(x))
})
setMethod("names", signature(x = "genpop"), function(x){
- temp <- rev(names(attributes(x)))[-1]
- return(rev(temp))
+ return(slotNames(x))
})
@@ -258,7 +263,7 @@
# Function genind
##################
## constructor of a genind object
-genind <- function(tab,pop=NULL,prevcall=NULL){
+genind <- function(tab,pop=NULL,prevcall=NULL,ploidy=2){
X <- as.matrix(tab)
if(is.null(colnames(X))) stop("tab columns have no name.")
@@ -338,6 +343,11 @@
res at pop.names <- pop.names
}
+ ## ploidy
+ plo <- as.integer(ploidy)
+ if(plo < as.integer(1)) stop("ploidy inferior to 1")
+ res at ploidy <- plo
+
if(is.null(prevcall)) {prevcall <- match.call()}
res at call <- prevcall
@@ -457,7 +467,8 @@
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\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"))
@@ -690,17 +701,18 @@
# pop.names <- levels(pop) ## no longer used
# tabcount is a matrix pop x alleles, counting alleles per pop
- # *2 to have alleles count
+ # *ploidy to have alleles counts
f1 <- function(v){
if(all(is.na(v))) return(NA) else return(sum(v,na.rm=TRUE))
}
f2 <- function(v){
if(all(is.na(v)) || sum(v,na.rm=TRUE)==0) return(NA)
- return(v/(sum(v,na.rm=TRUE)))
+ return(v/(sum(v,na.rm=TRUE)))
}
- tabcount <- 2* apply(x at tab,2,function(c) tapply(c,pop,f1))
+ tabcount <- x at ploidy * apply(x at tab,2,function(c) tapply(c,pop,f1))
+ tabcount <- round(tabcount,digits=0)
# restitute matrix class when only one pop
if(is.null(dim(tabcount))) {
lab.col <- names(tabcount)
Modified: pkg/R/fstat.R
===================================================================
--- pkg/R/fstat.R 2008-06-25 12:39:32 UTC (rev 131)
+++ pkg/R/fstat.R 2008-06-25 16:36:11 UTC (rev 132)
@@ -23,22 +23,22 @@
-###############
-# fst function
-###############
-#
-# classical fst sensu Weir 1996 Genetic data analysis II pp. 166-167
-#
-fst <- function(x, pop=NULL){
- ## 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.")
+## ###############
+## # fst function
+## ###############
+## #
+## # classical fst sensu Weir 1996 Genetic data analysis II pp. 166-167
+## #
+## fst <- function(x, pop=NULL){
+## ## 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(is.null(pop)) pop <- x at pop
- if(is.null(pop)) stop("no pop factor provided")
- if(length(pop)!=nrow(x at tab)) stop("pop has a wrong length.")
+## if(is.null(pop)) pop <- x at pop
+## if(is.null(pop)) stop("no pop factor provided")
+## if(length(pop)!=nrow(x at tab)) stop("pop has a wrong length.")
- ## computations
+## ## computations
- return(res)
-}
+## return(res)
+## }
Deleted: pkg/R/normalize.R
===================================================================
--- pkg/R/normalize.R 2008-06-25 12:39:32 UTC (rev 131)
+++ pkg/R/normalize.R 2008-06-25 16:36:11 UTC (rev 132)
@@ -1,61 +0,0 @@
-####################
-# normalize methods
-####################
-setGeneric("normalize", function(x,...){standardGeneric("normalize")})
-
-setMethod("normalize", "genind", function(x, center=TRUE, scale=TRUE,
- method=c("sigma", "binom"), truenames=TRUE){
-
- method <- match.arg(method)
-
- ## handle specific cases
- if(scale & tolower(method)=="binom"){
- ## get allele freq
- temp <- apply(x$tab,2,mean,na.rm=TRUE)
- ## coerce sum of alleles freq to one (in case of missing data)
- temp <- tapply(temp, x$loc.fac, function(vec) return(vec/sum(vec)))
- pbar <- unlist(temp)
-
- scale <- sqrt(pbar*(1-pbar))
- }
-
- X <- x$tab
- ## handle truenames
- if(truenames){
- X <- truenames(x)
- if(is.list(X)) { X <- X$tab }
- }
-
- ## return result
- res <- scale(X, center=center, scale=scale)
- return(res)
-})
-
-
-
-
-
-setMethod("normalize", "genpop", function(x, center=TRUE, scale=TRUE,
- method=c("sigma", "binom"), missing=NA, truenames=TRUE){
-
- method <- match.arg(method)
-
- ## make allele frequencies here
- X <- makefreq(x,quiet=TRUE,missing=missing,truenames=truenames)$tab
-
- ## handle specific cases
- if(scale & tolower(method)=="binom"){
- ## get allele freq
- temp <- apply(X,2,mean,na.rm=TRUE)
- ## coerce sum of alleles freq to one (in case of missing data)
- temp <- tapply(temp, x$loc.fac, function(vec) return(vec/sum(vec)))
- pbar <- unlist(temp)
-
- scale <- sqrt(pbar*(1-pbar))
- }
-
- ## return result
-
- res <- scale(X, center=center, scale=scale)
- return(res)
-})
Added: pkg/R/scale.R
===================================================================
--- pkg/R/scale.R (rev 0)
+++ pkg/R/scale.R 2008-06-25 16:36:11 UTC (rev 132)
@@ -0,0 +1,61 @@
+####################
+# scaleGen methods
+####################
+setGeneric("scaleGen", function(x,...){standardGeneric("scaleGen")})
+
+setMethod("scaleGen", "genind", function(x, center=TRUE, scale=TRUE,
+ method=c("sigma", "binom"), truenames=TRUE){
+
+ method <- match.arg(method)
+
+ ## handle specific cases
+ if(scale & tolower(method)=="binom"){
+ ## get allele freq
+ temp <- apply(x$tab,2,mean,na.rm=TRUE)
+ ## coerce sum of alleles freq to one (in case of missing data)
+ temp <- tapply(temp, x$loc.fac, function(vec) return(vec/sum(vec)))
+ pbar <- unlist(temp)
+
+ scale <- sqrt(pbar*(1-pbar))
+ }
+
+ X <- x$tab
+ ## handle truenames
+ if(truenames){
+ X <- truenames(x)
+ if(is.list(X)) { X <- X$tab }
+ }
+
+ ## return result
+ res <- scale(X, center=center, scale=scale)
+ return(res)
+})
+
+
+
+
+
+setMethod("scaleGen", "genpop", function(x, center=TRUE, scale=TRUE,
+ method=c("sigma", "binom"), missing=NA, truenames=TRUE){
+
+ method <- match.arg(method)
+
+ ## make allele frequencies here
+ X <- makefreq(x,quiet=TRUE,missing=missing,truenames=truenames)$tab
+
+ ## handle specific cases
+ if(scale & tolower(method)=="binom"){
+ ## get allele freq
+ temp <- apply(X,2,mean,na.rm=TRUE)
+ ## coerce sum of alleles freq to one (in case of missing data)
+ temp <- tapply(temp, x$loc.fac, function(vec) return(vec/sum(vec)))
+ pbar <- unlist(temp)
+
+ scale <- sqrt(pbar*(1-pbar))
+ }
+
+ ## return result
+
+ res <- scale(X, center=center, scale=scale)
+ return(res)
+})
More information about the adegenet-commits
mailing list