[adegenet-commits] r240 - pkg/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sun Jan 25 17:55:56 CET 2009
Author: jombart
Date: 2009-01-25 17:55:56 +0100 (Sun, 25 Jan 2009)
New Revision: 240
Modified:
pkg/R/HWE.R
pkg/R/auxil.R
pkg/R/gstat.randtest.R
pkg/R/handling.R
pkg/R/hybridize.R
Log:
checkTypes...
Modified: pkg/R/HWE.R
===================================================================
--- pkg/R/HWE.R 2009-01-25 16:48:03 UTC (rev 239)
+++ pkg/R/HWE.R 2009-01-25 16:55:56 UTC (rev 240)
@@ -3,18 +3,19 @@
##################
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")
-
+ checkType(x)
+
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)
@@ -27,7 +28,7 @@
}
return(res)
}
-
+
res <- lapply(kGen,function(e) lapply(e,ftest,permut,nsim))
# clean non-tested elements in the results list
@@ -46,6 +47,6 @@
rownames(res) <- gsub(".X-squared","",rnam)
res <- as.matrix(res)
}
-
- return(res)
+
+ return(res)
}
Modified: pkg/R/auxil.R
===================================================================
--- pkg/R/auxil.R 2009-01-25 16:48:03 UTC (rev 239)
+++ pkg/R/auxil.R 2009-01-25 16:55:56 UTC (rev 240)
@@ -94,7 +94,7 @@
currFunction <- sub("[[:space:]]*[(].*","",currCall)
## names of functions which are ok for dominant markers
- dominOk <- c("genind","genpop","genind2genpop","na.replace","nLoc")
+ dominOk <- c("genind","genpop","genind2genpop","summary","na.replace","nLoc")
if(! currFunction %in% dominOk){
msgError <- paste(currFunction,"is not implemented for dominant markers")
Modified: pkg/R/gstat.randtest.R
===================================================================
--- pkg/R/gstat.randtest.R 2009-01-25 16:48:03 UTC (rev 239)
+++ pkg/R/gstat.randtest.R 2009-01-25 16:55:56 UTC (rev 240)
@@ -3,12 +3,13 @@
##########################
gstat.randtest <- function(x,pop=NULL, method=c("global","within","between"),
sup.pop=NULL, sub.pop=NULL, nsim=499){
-
+
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")
+ checkType(x)
if(!require(hierfstat)) stop("hierfstat package is required. Please install it.")
if(!require(ade4)) stop("ade4 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)))
if(length(pop)!=nrow(x at tab)) stop("pop has a wrong length.")
@@ -19,40 +20,40 @@
# make data for hierfstat
X <- genind2hierfstat(x=x,pop=pop)
-
+
# compute obs gstat
obs <- g.stats.glob(X)$g.stats
pop <- X[,1]
X <- X[,-1]
-
+
# simulations according one of the 3 different schemes
# note: for, lapply and sapply are all equivalent
# recursive functions would require options("expression") to be modified...
sim <- vector(mode="numeric",length=nsim)
-
+
if(met=="global"){
-
+
sim <- sapply(1:nsim, function(i) g.stats.glob(cbind(sample(pop),X))$g.stats)
-
+
} else if(met=="within"){
if(length(sup.pop) != length(pop)) stop("pop and sup.pop do not have the same length.")
sim <- sapply(1:nsim, function(i) g.stats.glob(cbind(pop,X[samp.within(sup.pop),]))$g.stats)
-
+
} else if(met=="between"){
if(length(sub.pop) != length(pop)) stop("pop and sub.pop do not have the same length.")
sim <- sapply(1:nsim, function(i) g.stats.glob(cbind(pop,X[samp.between(sub.pop),]))$g.stats)
-
+
} else {
stop("Unknown method requested.")
}
prevcall <- match.call()
-
+
res <- as.randtest(sim=sim, obs=obs, call=prevcall)
- return(res)
-
+ return(res)
+
}
Modified: pkg/R/handling.R
===================================================================
--- pkg/R/handling.R 2009-01-25 16:48:03 UTC (rev 239)
+++ pkg/R/handling.R 2009-01-25 16:55:56 UTC (rev 240)
@@ -13,23 +13,23 @@
setGeneric("truenames", function(x) standardGeneric("truenames"))
setMethod("truenames", signature(x="genind"), function(x){
+ checkType(x)
+ X <- x at tab
+ if(!all(x at ind.names=="")) {rownames(X) <- x at ind.names}
- 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
- 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))
+ }
- if(!is.null(x at pop)){
- pop <- x at pop
- levels(pop) <- x at pop.names
- return(list(tab=X,pop=pop))
- }
-
- return(X)
+ return(X)
}
-)
+ )
@@ -39,15 +39,16 @@
# Method truenames for genpop
##############################
setMethod("truenames",signature(x="genpop"), function(x){
+ checkType(x)
- X <- x at tab
- if(!all(x at pop.names=="")) {rownames(X) <- x at pop.names}
+ 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
+ labcol <- rep(x at loc.names,x at loc.nall)
+ labcol <- paste(labcol,unlist(x at all.names),sep=".")
+ colnames(X) <- labcol
- return(X)
+ return(X)
})
@@ -59,44 +60,45 @@
setGeneric("seploc", function(x, ...) standardGeneric("seploc"))
setMethod("seploc", signature(x="genind"), function(x,truenames=TRUE,res.type=c("genind","matrix")){
+ checkType(x)
- if(!is.genind(x)) stop("x is not a valid genind object")
- res.type <- match.arg(res.type)
- if(res.type=="genind") { truenames <- TRUE }
+ 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
+ temp <- x at loc.fac
+ nloc <- length(levels(temp))
+ levels(temp) <- 1:nloc
- kX <- list()
+ kX <- list()
- for(i in 1:nloc){
- kX[[i]] <- matrix(x at tab[,temp==i],ncol=x at loc.nall[i])
+ 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){
+ 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)
- }
+ 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
- }
- }
+ 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)
+ return(kX)
})
@@ -105,44 +107,45 @@
# Method seploc for genpop
###########################
setMethod("seploc", signature(x="genpop"), function(x,truenames=TRUE,res.type=c("genpop","matrix")){
+ checkType(x)
- if(!is.genpop(x)) stop("x is not a valid genpop object")
- res.type <- match.arg(res.type)
- if(res.type=="genpop") { truenames <- TRUE }
+ 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
+ temp <- x at loc.fac
+ nloc <- length(levels(temp))
+ levels(temp) <- 1:nloc
- kX <- list()
+ kX <- list()
- for(i in 1:nloc){
- kX[[i]] <- matrix(x at tab[,temp==i],ncol=x at loc.nall[i])
+ 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){
+ 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)
- }
+ 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
- }
- }
+ 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)
+ return(kX)
})
@@ -297,6 +300,7 @@
## genind
setMethod("seppop", signature(x="genind"), function(x,pop=NULL,truenames=TRUE,res.type=c("genind","matrix")){
+ checkType(x)
## misc checks
if(!is.genind(x)) stop("x is not a valid genind object")
@@ -340,6 +344,7 @@
## genind method
setMethod("na.replace", signature(x="genind"), function(x,method, quiet=FALSE){
+ checkType(x)
## preliminary stuff
validObject(x)
@@ -380,6 +385,7 @@
## genpop method
setMethod("na.replace", signature(x="genpop"), function(x,method, quiet=FALSE){
+ checkType(x)
## preliminary stuff
validObject(x)
Modified: pkg/R/hybridize.R
===================================================================
--- pkg/R/hybridize.R 2009-01-25 16:48:03 UTC (rev 239)
+++ pkg/R/hybridize.R 2009-01-25 16:55:56 UTC (rev 240)
@@ -10,7 +10,9 @@
if(!is.genind(x2)) stop("x2 is not a valid genind object")
if(x1 at ploidy != as.integer(2)) stop("not implemented for non-diploid genotypes")
if(x2 at ploidy != as.integer(2)) stop("not implemented for non-diploid genotypes")
-
+ checkType(x1)
+ checkType(x2)
+
n <- as.integer(n)
res.type <- match.arg(res.type)
if(!all(x1 at loc.names==x2 at loc.names)) stop("names of markers in x1 and x2 do not correspond")
@@ -19,7 +21,7 @@
n1 <- nrow(x1$tab)
n2 <- nrow(x2$tab)
k <- length(x1$loc.names)
-
+
#### get frequencies for each locus
y1 <- genind2genpop(x1,pop=factor(rep(1,n1)),missing="0",quiet=TRUE)
freq1 <- makefreq(y1,quiet=TRUE)$tab
@@ -37,8 +39,8 @@
kX2 <- lapply(freq2, function(v) t(rmultinom(n,1,v)))
names(kX2) <- x2$loc.names
for(i in 1:k) { colnames(kX2[[i]]) <- x2$all.names[[i]]}
-
- ## tab1 / tab2 are cbinded tables
+
+ ## tab1 / tab2 are cbinded tables
tab1 <- cbind.data.frame(kX1)
## gam 1/2 are genind containing gametes
## gam 1
@@ -49,7 +51,7 @@
gam1 at loc.nall <- x1 at loc.nall
gam1 <- genind2df(gam1,sep="/",usepop=FALSE)
gam1 <- as.matrix(gam1)
-
+
## gam 2
tab2 <- cbind.data.frame(kX2)
## gam 1/2 are genind containing gametes
@@ -107,14 +109,14 @@
names(res) <- x1 at loc.names
row.names(res) <- .genlab(hyb.label,n)
if(is.null(pop)){ # if pop is not provided, merge the two parent populations
- pop <- paste(deparse(substitute(x1)) , deparse(substitute(x2)), sep="-")
+ pop <- paste(deparse(substitute(x1)) , deparse(substitute(x2)), sep="-")
}
pop <- factor(rep(pop,n))
-
+
res <- df2genind(res, pop=pop)
res at call <- match.call()
-
+
return(res)
}
-
+
} # end hybridize
More information about the adegenet-commits
mailing list