[adegenet-commits] r226 - pkg/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sat Jan 24 19:48:36 CET 2009
Author: jombart
Date: 2009-01-24 19:48:36 +0100 (Sat, 24 Jan 2009)
New Revision: 226
Added:
pkg/R/handling.R
Modified:
pkg/R/auxil.R
Log:
New file handling.R to separate data handling from auxiliary functions.
Modified: pkg/R/auxil.R
===================================================================
--- pkg/R/auxil.R 2009-01-24 18:43:22 UTC (rev 225)
+++ pkg/R/auxil.R 2009-01-24 18:48:36 UTC (rev 226)
@@ -7,143 +7,143 @@
###########################
-##############################
-# Method truenames for genind
-##############################
-setGeneric("truenames", function(x) standardGeneric("truenames"))
+## ##############################
+## # Method truenames for genind
+## ##############################
+## setGeneric("truenames", function(x) standardGeneric("truenames"))
-setMethod("truenames", signature(x="genind"), function(x){
+## setMethod("truenames", signature(x="genind"), function(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)
+## }
+## )
-##############################
-# Method truenames for genpop
-##############################
-setMethod("truenames",signature(x="genpop"), function(x){
+## ##############################
+## # Method truenames for genpop
+## ##############################
+## setMethod("truenames",signature(x="genpop"), function(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)
+## })
-###########################
-# Method seploc for genind
-###########################
-setGeneric("seploc", function(x, ...) standardGeneric("seploc"))
+## ###########################
+## # Method seploc for genind
+## ###########################
+## setGeneric("seploc", function(x, ...) standardGeneric("seploc"))
-setMethod("seploc", signature(x="genind"), function(x,truenames=TRUE,res.type=c("genind","matrix")){
+## 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 }
+## 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)
+## })
-###########################
-# Method seploc for genpop
-###########################
-setMethod("seploc", signature(x="genpop"), function(x,truenames=TRUE,res.type=c("genpop","matrix")){
+## ###########################
+## # 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 }
+## 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)
+## })
@@ -185,322 +185,322 @@
-###############
-# '$' operator
-###############
-setMethod("$","genind",function(x,name) {
- return(slot(x,name))
-})
+## ###############
+## # '$' operator
+## ###############
+## setMethod("$","genind",function(x,name) {
+## return(slot(x,name))
+## })
-setMethod("$<-","genind",function(x,name,value) {
- slot(x,name,check=TRUE) <- value
- return(x)
-})
+## setMethod("$<-","genind",function(x,name,value) {
+## slot(x,name,check=TRUE) <- value
+## return(x)
+## })
-setMethod("$","genpop",function(x,name) {
- return(slot(x,name))
-})
+## setMethod("$","genpop",function(x,name) {
+## return(slot(x,name))
+## })
-setMethod("$<-","genpop",function(x,name,value) {
- slot(x,name,check=TRUE) <- value
- return(x)
-})
+## setMethod("$<-","genpop",function(x,name,value) {
+## slot(x,name,check=TRUE) <- value
+## return(x)
+## })
-###############
-# '[' operator
-###############
-## genind
-setMethod("[","genind",
- function(x, i, j, ..., loc=NULL, treatOther=TRUE, drop=FALSE) {
+## ###############
+## # '[' operator
+## ###############
+## ## genind
+## setMethod("[","genind",
+## function(x, i, j, ..., loc=NULL, treatOther=TRUE, drop=FALSE) {
- if (missing(i)) i <- TRUE
- if (missing(j)) j <- TRUE
+## if (missing(i)) i <- TRUE
+## if (missing(j)) j <- TRUE
- pop <- NULL
- if(is.null(x at pop)) { tab <- truenames(x) }
- if(!is.null(x at pop)) {
- temp <- truenames(x)
- tab <- temp$tab
- pop <- temp$pop
- pop <- factor(pop[i])
- }
+## pop <- NULL
+## if(is.null(x at pop)) { tab <- truenames(x) }
+## if(!is.null(x at pop)) {
+## temp <- truenames(x)
+## tab <- temp$tab
+## pop <- temp$pop
+## pop <- factor(pop[i])
+## }
- ## handle loc argument
- if(!is.null(loc)){
- loc <- as.character(loc)
- temp <- !loc %in% x at loc.fac
- if(any(temp)) { # si mauvais loci
- warning(paste("the following specified loci do not exist:", loc[temp]))
- }
- j <- x$loc.fac %in% loc
- } # end loc argument
+## ## handle loc argument
+## if(!is.null(loc)){
+## loc <- as.character(loc)
+## temp <- !loc %in% x at loc.fac
+## if(any(temp)) { # si mauvais loci
+## warning(paste("the following specified loci do not exist:", loc[temp]))
+## }
+## j <- x$loc.fac %in% loc
+## } # end loc argument
- prevcall <- match.call()
- tab <- tab[i, j, ...,drop=FALSE]
+## prevcall <- match.call()
+## tab <- tab[i, j, ...,drop=FALSE]
- res <- genind(tab,pop=pop,prevcall=prevcall)
+## res <- genind(tab,pop=pop,prevcall=prevcall)
- ## handle 'other' slot
- nOther <- length(x at other)
- namesOther <- names(x at other)
- counter <- 0
- if(treatOther){
- f1 <- function(obj,n=nrow(x at tab)){
- counter <<- counter+1
- if(!is.null(dim(obj)) && nrow(obj)==n) { # if the element is a matrix-like obj
- obj <- obj[i,,drop=FALSE]
- } else if(length(obj) == n) { # if the element is not a matrix but has a length == n
- obj <- obj[i]
- if(is.factor(obj)) {obj <- factor(obj)}
- } else {warning(paste("cannot treat the object",namesOther[counter]))}
+## ## handle 'other' slot
+## nOther <- length(x at other)
+## namesOther <- names(x at other)
+## counter <- 0
+## if(treatOther){
+## f1 <- function(obj,n=nrow(x at tab)){
+## counter <<- counter+1
+## if(!is.null(dim(obj)) && nrow(obj)==n) { # if the element is a matrix-like obj
+## obj <- obj[i,,drop=FALSE]
+## } else if(length(obj) == n) { # if the element is not a matrix but has a length == n
+## obj <- obj[i]
+## if(is.factor(obj)) {obj <- factor(obj)}
+## } else {warning(paste("cannot treat the object",namesOther[counter]))}
- return(obj)
- } # end f1
+## return(obj)
+## } # end f1
- res at other <- lapply(x at other, f1) # treat all elements
+## res at other <- lapply(x at other, f1) # treat all elements
- } # end treatOther
+## } # end treatOther
- return(res)
- })
+## return(res)
+## })
-## genpop
-setMethod("[","genpop",
- function(x, i, j, ..., loc=NULL, treatOther=TRUE, drop=FALSE) {
+## ## genpop
+## setMethod("[","genpop",
+## function(x, i, j, ..., loc=NULL, treatOther=TRUE, drop=FALSE) {
- if (missing(i)) i <- TRUE
- if (missing(j)) j <- TRUE
+## if (missing(i)) i <- TRUE
+## if (missing(j)) j <- TRUE
- tab <- truenames(x)
+## tab <- truenames(x)
- ## handle loc argument
- if(!is.null(loc)){
- loc <- as.character(loc)
- temp <- !loc %in% x at loc.fac
- if(any(temp)) { # si mauvais loci
- warning(paste("the following specified loci do not exist:", loc[temp]))
- }
- j <- x$loc.fac %in% loc
- } # end loc argument
+## ## handle loc argument
+## if(!is.null(loc)){
+## loc <- as.character(loc)
+## temp <- !loc %in% x at loc.fac
+## if(any(temp)) { # si mauvais loci
+## warning(paste("the following specified loci do not exist:", loc[temp]))
+## }
+## j <- x$loc.fac %in% loc
+## } # end loc argument
- prevcall <- match.call()
- tab <- tab[i, j, ...,drop=FALSE]
+## prevcall <- match.call()
+## tab <- tab[i, j, ...,drop=FALSE]
- res <- genpop(tab,prevcall=prevcall)
+## res <- genpop(tab,prevcall=prevcall)
- ## handle 'other' slot
- nOther <- length(x at other)
- namesOther <- names(x at other)
- counter <- 0
- if(treatOther){
- f1 <- function(obj,n=nrow(x at tab)){
- counter <<- counter+1
- if(!is.null(dim(obj)) && nrow(obj)==n) { # if the element is a matrix-like obj
- obj <- obj[i,,drop=FALSE]
- } else if(length(obj) == n) { # if the element is not a matrix but has a length == n
- obj <- obj[i]
- if(is.factor(obj)) {obj <- factor(obj)}
- } else {warning(paste("cannot treat the object",namesOther[counter]))}
+## ## handle 'other' slot
+## nOther <- length(x at other)
+## namesOther <- names(x at other)
+## counter <- 0
+## if(treatOther){
+## f1 <- function(obj,n=nrow(x at tab)){
+## counter <<- counter+1
+## if(!is.null(dim(obj)) && nrow(obj)==n) { # if the element is a matrix-like obj
+## obj <- obj[i,,drop=FALSE]
+## } else if(length(obj) == n) { # if the element is not a matrix but has a length == n
+## obj <- obj[i]
+## if(is.factor(obj)) {obj <- factor(obj)}
+## } else {warning(paste("cannot treat the object",namesOther[counter]))}
- return(obj)
- } # end f1
+## return(obj)
+## } # end f1
- res at other <- lapply(x at other, f1) # treat all elements
+## res at other <- lapply(x at other, f1) # treat all elements
- } # end treatOther
+## } # end treatOther
- return(res)
- })
+## return(res)
+## })
-##################
-# Function seppop
-##################
-setGeneric("seppop", function(x, ...) standardGeneric("seppop"))
+## ##################
+## # Function seppop
+## ##################
+## setGeneric("seppop", function(x, ...) standardGeneric("seppop"))
-## genind
-setMethod("seppop", signature(x="genind"), function(x,pop=NULL,truenames=TRUE,res.type=c("genind","matrix")){
+## ## genind
+## setMethod("seppop", signature(x="genind"), function(x,pop=NULL,truenames=TRUE,res.type=c("genind","matrix")){
- ## misc checks
- if(!is.genind(x)) stop("x is not a valid genind object")
- if(is.null(pop)) { # pop taken from @pop
- pop <- x at pop
- levels(pop) <- x at pop.names
- }
+## ## misc checks
+## if(!is.genind(x)) stop("x is not a valid genind object")
+## 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")
+## 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 }
+## res.type <- match.arg(res.type)
+## if(res.type=="genind") { truenames <- TRUE }
- ## pop <- x at pop # comment to take pop arg into account
+## ## 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)
+## ## 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 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)
- }
+## ## 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)
-}) # end seppop
+## return(res)
+## }) # end seppop
-#####################
-# Methods na.replace
-#####################
-setGeneric("na.replace", function(x, ...) standardGeneric("na.replace"))
+## #####################
+## # Methods na.replace
+## #####################
+## setGeneric("na.replace", function(x, ...) standardGeneric("na.replace"))
-## genind method
-setMethod("na.replace", signature(x="genind"), function(x,method, quiet=FALSE){
+## ## genind method
+## setMethod("na.replace", signature(x="genind"), function(x,method, quiet=FALSE){
- ## preliminary stuff
- validObject(x)
- if(!any(is.na(x at tab))) {
- if(!quiet) cat("\n Replaced 0 missing values \n")
- return(x)
- }
- method <- tolower(method)
- method <- match.arg(method, c("0","mean"))
+## ## preliminary stuff
+## validObject(x)
+## if(!any(is.na(x at tab))) {
+## if(!quiet) cat("\n Replaced 0 missing values \n")
+## return(x)
+## }
+## method <- tolower(method)
+## method <- match.arg(method, c("0","mean"))
- res <- x
+## res <- x
- if(method=="0"){
- res at tab[is.na(x at tab)] <- 0
- }
+## if(method=="0"){
+## res at tab[is.na(x at tab)] <- 0
+## }
- if(method=="mean"){
- f1 <- function(vec){
- m <- mean(vec,na.rm=TRUE)
- vec[is.na(vec)] <- m
- return(vec)
- }
+## if(method=="mean"){
+## f1 <- function(vec){
+## m <- mean(vec,na.rm=TRUE)
+## vec[is.na(vec)] <- m
+## return(vec)
+## }
- res at tab <- apply(x at tab, 2, f1)
- }
+## res at tab <- apply(x at tab, 2, f1)
+## }
- if(!quiet){
- Nna <- sum(is.na(x at tab))
- cat("\n Replaced",Nna,"missing values \n")
- }
+## if(!quiet){
+## Nna <- sum(is.na(x at tab))
+## cat("\n Replaced",Nna,"missing values \n")
+## }
- return(res)
+## return(res)
-})
+## })
-## genpop method
-setMethod("na.replace", signature(x="genpop"), function(x,method, quiet=FALSE){
+## ## genpop method
+## setMethod("na.replace", signature(x="genpop"), function(x,method, quiet=FALSE){
- ## preliminary stuff
- validObject(x)
- if(!any(is.na(x at tab))) {
- if(!quiet) cat("\n Replaced 0 missing values \n")
- return(x)
- }
+## ## preliminary stuff
+## validObject(x)
+## if(!any(is.na(x at tab))) {
+## if(!quiet) cat("\n Replaced 0 missing values \n")
+## return(x)
+## }
- method <- tolower(method)
- method <- match.arg(method, c("0","chi2"))
+## method <- tolower(method)
+## method <- match.arg(method, c("0","chi2"))
- res <- x
+## res <- x
- if(method=="0"){
- res at tab[is.na(x at tab)] <- 0
- }
+## if(method=="0"){
+## res at tab[is.na(x at tab)] <- 0
+## }
- if(method=="chi2"){
- ## compute theoretical counts
- ## (same as in a Chi-squared)
- X <- x at tab
- sumPop <- apply(X,1,sum,na.rm=TRUE)
- sumLoc <- apply(X,2,sum,na.rm=TRUE)
- X.theo <- sumPop %o% sumLoc / sum(X,na.rm=TRUE)
+## if(method=="chi2"){
+## ## compute theoretical counts
+## ## (same as in a Chi-squared)
+## X <- x at tab
+## sumPop <- apply(X,1,sum,na.rm=TRUE)
+## sumLoc <- apply(X,2,sum,na.rm=TRUE)
+## X.theo <- sumPop %o% sumLoc / sum(X,na.rm=TRUE)
- X[is.na(X)] <- X.theo[is.na(X)]
- res at tab <- X
- }
+## X[is.na(X)] <- X.theo[is.na(X)]
+## res at tab <- X
+## }
- if(!quiet){
- Nna <- sum(is.na(x at tab))
- cat("\n Replaced",Nna,"missing values \n")
- }
+## if(!quiet){
+## Nna <- sum(is.na(x at tab))
+## cat("\n Replaced",Nna,"missing values \n")
+## }
- return(res)
-})
+## return(res)
+## })
-##################
-# Function repool
-##################
-repool <- function(...){
+## ##################
+## # Function repool
+## ##################
+## repool <- function(...){
- ## preliminary stuff
- x <- list(...)
- if(is.list(x[[1]])) x <- x[[1]] ## if ... is a list, keep this list for x
- if(!inherits(x,"list")) stop("x must be a list")
- if(!all(sapply(x,is.genind))) stop("x is does not contain only valid genind objects")
- temp <- sapply(x,function(e) e$loc.names)
- 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")
+## ## preliminary stuff
+## x <- list(...)
+## if(is.list(x[[1]])) x <- x[[1]] ## if ... is a list, keep this list for x
+## if(!inherits(x,"list")) stop("x must be a list")
+## if(!all(sapply(x,is.genind))) stop("x is does not contain only valid genind objects")
+## temp <- sapply(x,function(e) e$loc.names)
+## 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){
- if(is.null(obj$pop)) return(factor(rep(NA,nrow(obj$tab))))
- pop <- obj$pop
- levels(pop) <- obj$pop.names
- return(pop)
- }
+## ## extract info
+## listTab <- lapply(x,genind2df,usepop=FALSE)
+## getPop <- function(obj){
+## if(is.null(obj$pop)) return(factor(rep(NA,nrow(obj$tab))))
+## pop <- obj$pop
+## levels(pop) <- obj$pop.names
+## return(pop)
+## }
- ## handle pop
- listPop <- lapply(x, getPop)
- pop <- unlist(listPop, use.name=FALSE)
- pop <- factor(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
+## ## 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]]
- for(i in 2:length(x)){
- tab <- rbind(tab,listTab[[i]])
- }
+## ## bind all tabs by rows
+## tab <- listTab[[1]]
+## for(i in 2:length(x)){
+## tab <- rbind(tab,listTab[[i]])
+## }
- res <- df2genind(tab,pop=pop)
- res$call <- match.call()
+## res <- df2genind(tab,pop=pop)
+## res$call <- match.call()
- return(res)
-} # end repool
+## return(res)
+## } # end repool
@@ -510,22 +510,22 @@
######################
-#######
-# nLoc
-#######
-setGeneric("nLoc", function(x,...){
- standardGeneric("nLoc")
-})
+## #######
+## # nLoc
+## #######
+## setGeneric("nLoc", function(x,...){
+## standardGeneric("nLoc")
+## })
-setMethod("nLoc","genind", function(x,...){
- return(length(x at loc.names))
-})
+## setMethod("nLoc","genind", function(x,...){
+## return(length(x at loc.names))
+## })
-setMethod("nLoc","genpop", function(x,...){
- return(length(x at loc.names))
-})
+## setMethod("nLoc","genpop", function(x,...){
+## return(length(x at loc.names))
+## })
Added: pkg/R/handling.R
===================================================================
--- pkg/R/handling.R (rev 0)
+++ pkg/R/handling.R 2009-01-24 18:48:36 UTC (rev 226)
@@ -0,0 +1,495 @@
+###########################
+#
+# Auxiliary functions for
+# adegenet objects
+#
+# T. Jombart
+###########################
+
+
+##############################
+# Method truenames for genind
+##############################
+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}
+
+ 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))
+ }
+
+ return(X)
+}
+)
+
+
+
+
+
+##############################
+# Method truenames for genpop
+##############################
+setMethod("truenames",signature(x="genpop"), function(x){
+
+ 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
+
+ return(X)
+})
+
+
+
+
+###########################
+# Method seploc for genind
+###########################
+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])
+
+ 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)
+ }
+
+ 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)
+})
+
+
+
+###########################
+# 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])
+
+ 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)
+ }
+
+ 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)
+})
+
+
+
+
+
+###############
+# '$' operator
+###############
+setMethod("$","genind",function(x,name) {
+ return(slot(x,name))
+})
+
+
+setMethod("$<-","genind",function(x,name,value) {
+ slot(x,name,check=TRUE) <- value
+ return(x)
+})
+
+
+setMethod("$","genpop",function(x,name) {
+ return(slot(x,name))
+})
+
+
+setMethod("$<-","genpop",function(x,name,value) {
+ slot(x,name,check=TRUE) <- value
+ return(x)
+})
+
+
+
+
+
+###############
+# '[' operator
+###############
+## genind
+setMethod("[","genind",
+ function(x, i, j, ..., loc=NULL, treatOther=TRUE, drop=FALSE) {
+
+ if (missing(i)) i <- TRUE
+ if (missing(j)) j <- TRUE
+
+ pop <- NULL
+ if(is.null(x at pop)) { tab <- truenames(x) }
+ if(!is.null(x at pop)) {
+ temp <- truenames(x)
+ tab <- temp$tab
+ pop <- temp$pop
+ pop <- factor(pop[i])
+ }
+
+ ## handle loc argument
+ if(!is.null(loc)){
+ loc <- as.character(loc)
+ temp <- !loc %in% x at loc.fac
+ if(any(temp)) { # si mauvais loci
+ warning(paste("the following specified loci do not exist:", loc[temp]))
+ }
+ 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
+ nOther <- length(x at other)
+ namesOther <- names(x at other)
+ counter <- 0
+ if(treatOther){
+ f1 <- function(obj,n=nrow(x at tab)){
+ counter <<- counter+1
+ if(!is.null(dim(obj)) && nrow(obj)==n) { # if the element is a matrix-like obj
+ obj <- obj[i,,drop=FALSE]
+ } else if(length(obj) == n) { # if the element is not a matrix but has a length == n
+ 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)
+ })
+
+
+## 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)
+
+ ## handle loc argument
+ if(!is.null(loc)){
+ loc <- as.character(loc)
+ temp <- !loc %in% x at loc.fac
+ if(any(temp)) { # si mauvais loci
+ warning(paste("the following specified loci do not exist:", loc[temp]))
+ }
+ j <- x$loc.fac %in% loc
+ } # end loc argument
+
+ prevcall <- match.call()
+ tab <- tab[i, j, ...,drop=FALSE]
+
+ res <- genpop(tab,prevcall=prevcall)
+
+ ## handle 'other' slot
+ nOther <- length(x at other)
+ namesOther <- names(x at other)
+ counter <- 0
+ if(treatOther){
+ f1 <- function(obj,n=nrow(x at tab)){
+ counter <<- counter+1
+ if(!is.null(dim(obj)) && nrow(obj)==n) { # if the element is a matrix-like obj
+ obj <- obj[i,,drop=FALSE]
+ } else if(length(obj) == n) { # if the element is not a matrix but has a length == n
+ 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)
+ })
+
+
+
+
+
+
+##################
+# Function seppop
+##################
+setGeneric("seppop", function(x, ...) standardGeneric("seppop"))
+
+## genind
+setMethod("seppop", signature(x="genind"), function(x,pop=NULL,truenames=TRUE,res.type=c("genind","matrix")){
+
+ ## misc checks
+ if(!is.genind(x)) stop("x is not a valid genind object")
+ 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)
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/adegenet -r 226
More information about the adegenet-commits
mailing list