[adegenet-commits] r284 - pkg/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Apr 1 18:47:09 CEST 2009
Author: jombart
Date: 2009-04-01 18:47:09 +0200 (Wed, 01 Apr 2009)
New Revision: 284
Modified:
pkg/R/handling.R
pkg/R/hybridize.R
pkg/R/import.R
Log:
hybridize fixed, now works for any even level of ploidy.
repool fixed.
df2genind fixed.
Modified: pkg/R/handling.R
===================================================================
--- pkg/R/handling.R 2009-04-01 13:46:35 UTC (rev 283)
+++ pkg/R/handling.R 2009-04-01 16:47:09 UTC (rev 284)
@@ -483,7 +483,7 @@
## handle genotypes
markNames <- colnames(listTab[[1]])
- listTab <- lapply(listTab, function(tab) tab[,markNames]) # resorting of the tabs
+ listTab <- lapply(listTab, function(tab) tab[,markNames,drop=FALSE]) # resorting of the tabs
## bind all tabs by rows
tab <- listTab[[1]]
Modified: pkg/R/hybridize.R
===================================================================
--- pkg/R/hybridize.R 2009-04-01 13:46:35 UTC (rev 283)
+++ pkg/R/hybridize.R 2009-04-01 16:47:09 UTC (rev 284)
@@ -4,16 +4,18 @@
## in both objects.
##
-hybridize <- function(x1, x2, n, pop=NULL, res.type=c("genind","df","STRUCTURE"), file=NULL, quiet=FALSE, sep="/", hyb.label="h"){
+hybridize <- function(x1, x2, n, pop=NULL,
+ res.type=c("genind","df","STRUCTURE"), file=NULL, quiet=FALSE, sep="/", hyb.label="h"){
## checks
if(!is.genind(x1)) stop("x1 is not a valid genind object")
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")
+ if(x1 at ploidy %% 2 != 0) stop("not implemented for odd levels of ploidy")
+ if(x2 at ploidy != x1 at ploidy) stop("not implemented for genotypes with different ploidy levels")
checkType(x1)
checkType(x2)
n <- as.integer(n)
+ ploidy <- x1 at ploidy
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")
@@ -33,50 +35,57 @@
#### sampling of gametes
## kX1 / kX2 are lists of tables of sampled gametes
- kX1 <- lapply(freq1, function(v) t(rmultinom(n,1,v)))
+ kX1 <- lapply(freq1, function(v) t(rmultinom(n,ploidy/2,v)))
names(kX1) <- x1$loc.names
for(i in 1:k) { colnames(kX1[[i]]) <- x1$all.names[[i]]}
- kX2 <- lapply(freq2, function(v) t(rmultinom(n,1,v)))
+ kX2 <- lapply(freq2, function(v) t(rmultinom(n,ploidy/2,v)))
names(kX2) <- x2$loc.names
for(i in 1:k) { colnames(kX2[[i]]) <- x2$all.names[[i]]}
## tab1 / tab2 are cbinded tables
- tab1 <- cbind.data.frame(kX1)
+ ## tab1 <- cbind.data.frame(kX1)
## gam 1/2 are genind containing gametes
## gam 1
- gam1 <- genind(tab1)
- gam1 at loc.names <- x1 at loc.names
- gam1 at loc.fac <- x1 at loc.fac
- gam1 at all.names <- x1 at all.names
- gam1 at loc.nall <- x1 at loc.nall
- gam1 <- genind2df(gam1,sep="/",usepop=FALSE)
- gam1 <- as.matrix(gam1)
+ ## gam1 <- genind(tab1, ploidy=ploidy/2)
+ ## gam1 at loc.names <- x1 at loc.names
+ ## gam1 at loc.fac <- x1 at loc.fac
+ ## gam1 at all.names <- x1 at all.names
+ ## gam1 at loc.nall <- x1 at loc.nall
+ ## gam1 <- genind2df(gam1,sep="/",usepop=FALSE)
+ ## gam1 <- as.matrix(gam1)
- ## gam 2
+ ## ## gam 2
+ ## tab2 <- cbind.data.frame(kX2)
+ ## ## gam 1/2 are genind containing gametes
+ ## gam2 <- genind(tab2, ploidy=ploidy/2)
+ ## gam2 at loc.names <- x2 at loc.names
+ ## gam2 at loc.fac <- x2 at loc.fac
+ ## gam2 at all.names <- x2 at all.names
+ ## gam2 at loc.nall <- x2 at loc.nall
+ ## gam2 <- genind2df(gam2,sep="/",usepop=FALSE)
+ ## gam2 <- as.matrix(gam2)
+
+ ## construction of zygotes ##
+ ## gam1 <- gsub("/.*$","",gam1)
+ ## gam2 <- gsub("/.*$","",gam2)
+ tab1 <- cbind.data.frame(kX1)
tab2 <- cbind.data.frame(kX2)
- ## gam 1/2 are genind containing gametes
- gam2 <- genind(tab2)
- gam2 at loc.names <- x2 at loc.names
- gam2 at loc.fac <- x2 at loc.fac
- gam2 at all.names <- x2 at all.names
- gam2 at loc.nall <- x2 at loc.nall
- gam2 <- genind2df(gam2,sep="/",usepop=FALSE)
- gam2 <- as.matrix(gam2)
+ zyg <- (tab1 + tab2)/ploidy
+ row.names(zyg) <- .genlab(hyb.label,n)
+ zyg <- genind(zyg, type="codom", ploidy=ploidy)
- #### construction of zygotes
- gam1 <- gsub("/.*$","",gam1)
- gam2 <- gsub("/.*$","",gam2)
-
## res.type=="STRUCTURE"
if(res.type=="STRUCTURE"){
- res <- paste(gam1,gam2,sep=" ") # make df for the hybrids
- res <- as.data.frame(matrix(res,ncol=k))
- names(res) <- x1 at loc.names
- row.names(res) <- .genlab(hyb.label,n)
- df1 <- genind2df(x1,sep=" ",usepop=FALSE) # make df with parents and hybrids
- df2 <- genind2df(x2,sep=" ",usepop=FALSE)
- res <- rbind.data.frame(df1,df2,res) # rbind the three df
- res[is.na(res)] <- "-9 -9" # this is two missing alleles for STRUCTURE
+ ## res <- paste(gam1,gam2,sep=" ") # make df for the hybrids
+ ## res <- as.data.frame(matrix(res,ncol=k))
+ temp <- genind2df(repool(x1,x2,zyg), usepop=FALSE, sep=" ")
+ res <- unlist(apply(temp,1,strsplit," "))
+ res <- as.data.frame(matrix(res, nrow=nrow(temp), byrow=TRUE))
+ colnames(res) <- rep(colnames(temp),each=ploidy)
+ ## df1 <- genind2df(x1,sep=" ",usepop=FALSE) # make df with parents and hybrids
+ ## df2 <- genind2df(x2,sep=" ",usepop=FALSE)
+ ## res <- rbind.data.frame(df1,df2,res) # rbind the three df
+ res[is.na(res)] <- "-9" # this is two missing alleles for STRUCTURE
pop <- rep(1:3,c(nrow(x1 at tab), nrow(x2 at tab), n)) # make a pop identifier
res <- cbind.data.frame(pop,res, stringsAsFactors = FALSE)
names(res)[1] <- ""
@@ -92,28 +101,32 @@
return(invisible())
}
+
## res.type=="df"
if(res.type=="df"){
- res <- paste(gam1,gam2,sep=sep)
- res <- as.data.frame(matrix(res,ncol=k), stringsAsFactors=FALSE)
- names(res) <- x1 at loc.names
- row.names(res) <- .genlab(hyb.label,n)
+ ## res <- paste(gam1,gam2,sep=sep)
+ ## res <- as.data.frame(matrix(res,ncol=k), stringsAsFactors=FALSE)
+ ## names(res) <- x1 at loc.names
+ ## row.names(res) <- .genlab(hyb.label,n)
+ res <- genind2df(zyg, sep=sep)
return(res)
}
+
## res.type=="genind"
if(res.type=="genind"){
- res <- paste(gam1,gam2,sep="")
- res <- as.data.frame(matrix(res,ncol=k), stringsAsFactors=FALSE)
- names(res) <- x1 at loc.names
- row.names(res) <- .genlab(hyb.label,n)
+ ## res <- paste(gam1,gam2,sep="")
+ ## res <- as.data.frame(matrix(res,ncol=k), stringsAsFactors=FALSE)
+ ## 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 <- factor(rep(pop,n))
- res <- df2genind(res, pop=pop)
+ res <- zyg
+ pop(res) <- pop
res at call <- match.call()
return(res)
Modified: pkg/R/import.R
===================================================================
--- pkg/R/import.R 2009-04-01 13:46:35 UTC (rev 283)
+++ pkg/R/import.R 2009-04-01 16:47:09 UTC (rev 284)
@@ -61,7 +61,7 @@
## Erase entierely non-type individuals
temp <- apply(X,1,function(r) all(is.na(r)))
if(any(temp)){
- X <- X[!temp,]
+ X <- X[!temp,,drop=FALSE]
pop <- pop[!temp]
warning("entirely non-type individual(s) deleted")
}
@@ -69,7 +69,7 @@
## erase non-polymorphic loci
temp <- apply(X, 2, function(loc) length(unique(loc[!is.na(loc)]))==1)
if(any(temp)){
- X <- X[,!temp]
+ X <- X[,!temp,drop=FALSE]
warning("non-polymorphic marker(s) deleted")
}
@@ -111,8 +111,8 @@
## Erase entierely non-typed loci
temp <- apply(tempX,2,function(c) all(is.na(c)))
if(any(temp)){
- X <- X[,!temp]
- tempX <- tempX[,!temp]
+ X <- X[,!temp,drop=FALSE]
+ tempX <- tempX[,!temp,drop=FALSE]
loc.names <- loc.names[!temp]
nloc <- ncol(X)
warning("entirely non-type marker(s) deleted")
@@ -121,8 +121,8 @@
## Erase entierely non-type individuals
temp <- apply(tempX,1,function(r) all(is.na(r)))
if(any(temp)){
- X <- X[!temp,]
- tempX <- tempX[!temp,]
+ X <- X[!temp,,drop=FALSE]
+ tempX <- tempX[!temp,,drop=FALSE]
pop <- pop[!temp]
ind.names <- ind.names[!temp]
n <- nrow(X)
More information about the adegenet-commits
mailing list