[adegenet-commits] r215 - branches/devel-unstable/R pkg/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Dec 5 14:16:45 CET 2008
Author: jombart
Date: 2008-12-05 14:16:44 +0100 (Fri, 05 Dec 2008)
New Revision: 215
Modified:
branches/devel-unstable/R/auxil.R
pkg/R/auxil.R
Log:
Small fix for seppop.
Modified: branches/devel-unstable/R/auxil.R
===================================================================
--- branches/devel-unstable/R/auxil.R 2008-12-04 21:57:46 UTC (rev 214)
+++ branches/devel-unstable/R/auxil.R 2008-12-05 13:16:44 UTC (rev 215)
@@ -13,7 +13,7 @@
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}
@@ -59,17 +59,17 @@
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])
@@ -95,8 +95,8 @@
kX[[i]]@other <- x at other
}
}
-
- return(kX)
+
+ return(kX)
})
@@ -105,17 +105,17 @@
# 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])
@@ -142,7 +142,7 @@
}
}
- return(kX)
+ return(kX)
})
@@ -241,10 +241,10 @@
}
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
@@ -265,21 +265,21 @@
} # end f1
res at other <- lapply(x at other, f1) # treat all elements
-
+
} # end treatOther
-
+
return(res)
})
## genpop
-setMethod("[","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)
+ tab <- truenames(x)
## handle loc argument
if(!is.null(loc)){
@@ -293,7 +293,7 @@
prevcall <- match.call()
tab <- tab[i, j, ...,drop=FALSE]
-
+
res <- genpop(tab,prevcall=prevcall)
## handle 'other' slot
@@ -309,15 +309,15 @@
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)
})
@@ -334,31 +334,35 @@
## genind
setMethod("seppop", signature(x="genind"), function(x,pop=NULL,truenames=TRUE,res.type=c("genind","matrix")){
- ## misc checks
+ ## 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)) { # pop taken from @pop
+ pop <- x at pop
+ levels(pop) <- x at pop.names
+ }
+
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
+ ## pop <- x at pop # comment to take pop arg into account
+
## 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)
+
+ return(res)
}) # end seppop
@@ -383,7 +387,7 @@
method <- match.arg(method, c("0","mean"))
res <- x
-
+
if(method=="0"){
res at tab[is.na(x at tab)] <- 0
}
@@ -424,7 +428,7 @@
method <- match.arg(method, c("0","chi2"))
res <- x
-
+
if(method=="0"){
res at tab[is.na(x at tab)] <- 0
}
@@ -467,7 +471,7 @@
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){
@@ -476,25 +480,25 @@
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]]
+ 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
Modified: pkg/R/auxil.R
===================================================================
--- pkg/R/auxil.R 2008-12-04 21:57:46 UTC (rev 214)
+++ pkg/R/auxil.R 2008-12-05 13:16:44 UTC (rev 215)
@@ -13,7 +13,7 @@
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}
@@ -59,17 +59,17 @@
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])
@@ -95,8 +95,8 @@
kX[[i]]@other <- x at other
}
}
-
- return(kX)
+
+ return(kX)
})
@@ -105,17 +105,17 @@
# 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])
@@ -142,7 +142,7 @@
}
}
- return(kX)
+ return(kX)
})
@@ -241,10 +241,10 @@
}
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
@@ -265,21 +265,21 @@
} # end f1
res at other <- lapply(x at other, f1) # treat all elements
-
+
} # end treatOther
-
+
return(res)
})
## genpop
-setMethod("[","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)
+ tab <- truenames(x)
## handle loc argument
if(!is.null(loc)){
@@ -293,7 +293,7 @@
prevcall <- match.call()
tab <- tab[i, j, ...,drop=FALSE]
-
+
res <- genpop(tab,prevcall=prevcall)
## handle 'other' slot
@@ -309,15 +309,15 @@
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)
})
@@ -334,31 +334,35 @@
## genind
setMethod("seppop", signature(x="genind"), function(x,pop=NULL,truenames=TRUE,res.type=c("genind","matrix")){
- ## misc checks
+ ## 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)) { # pop taken from @pop
+ pop <- x at pop
+ levels(pop) <- x at pop.names
+ }
+
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
+ ## pop <- x at pop # comment to take pop arg into account
+
## 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)
+
+ return(res)
}) # end seppop
@@ -383,7 +387,7 @@
method <- match.arg(method, c("0","mean"))
res <- x
-
+
if(method=="0"){
res at tab[is.na(x at tab)] <- 0
}
@@ -424,7 +428,7 @@
method <- match.arg(method, c("0","chi2"))
res <- x
-
+
if(method=="0"){
res at tab[is.na(x at tab)] <- 0
}
@@ -467,7 +471,7 @@
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){
@@ -476,25 +480,25 @@
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]]
+ 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
More information about the adegenet-commits
mailing list