[adegenet-commits] r235 - in pkg: R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sun Jan 25 16:19:50 CET 2009
Author: jombart
Date: 2009-01-25 16:19:50 +0100 (Sun, 25 Jan 2009)
New Revision: 235
Modified:
pkg/R/auxil.R
pkg/man/auxil.Rd
Log:
Modif to axil. Erase commented code.
Modified: pkg/R/auxil.R
===================================================================
--- pkg/R/auxil.R 2009-01-25 14:51:44 UTC (rev 234)
+++ pkg/R/auxil.R 2009-01-25 15:19:50 UTC (rev 235)
@@ -7,148 +7,6 @@
###########################
-## ##############################
-## # 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)
-## })
-
-
-
-
-
#######################
# Function rmspaces
#######################
@@ -197,6 +55,7 @@
+
############################
# Function adegenetTutorial
############################
@@ -223,347 +82,22 @@
-## ###############
-## # '$' operator
-## ###############
-## setMethod("$","genind",function(x,name) {
-## return(slot(x,name))
-## })
+############
+# checkType
+############
+checkType <- function(markType){
+ if(markType=="codom") return()
-## setMethod("$<-","genind",function(x,name,value) {
-## slot(x,name,check=TRUE) <- value
-## return(x)
-## })
+ currCall <- match.call()
+ currFunction <- sub("[[:space:]]*[(].*","",currCall)
+ ## names of functions which are ok for dominant markers
+ dominOk <- c("genind","genpop","genind2genpop","na.replace","nLoc")
-## setMethod("$","genpop",function(x,name) {
-## return(slot(x,name))
-## })
+ if(! currFunction %in% dominOk){
+ msgError <- paste(currFunction,"is not implemented for dominant markers")
+ stop(msgError)
+ }
+} # end checkType
-
-## 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)
-## if(res.type=="genind") { truenames <- TRUE }
-
-## ## 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)
-## }) # end seppop
-
-
-
-
-
-## #####################
-## # Methods na.replace
-## #####################
-## setGeneric("na.replace", function(x, ...) standardGeneric("na.replace"))
-
-## ## 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"))
-
-## res <- x
-
-## 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)
-## }
-
-## 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")
-## }
-
-## return(res)
-
-## })
-
-
-
-
-## ## 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)
-## }
-
-## method <- tolower(method)
-## method <- match.arg(method, c("0","chi2"))
-
-## res <- x
-
-## 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)
-
-## 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")
-## }
-
-## return(res)
-## })
-
-
-
-
-
-## ##################
-## # 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")
-
-## ## 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 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]])
-## }
-
-## res <- df2genind(tab,pop=pop)
-## res$call <- match.call()
-
-## return(res)
-## } # end repool
-
-
-
-
-######################
-## miscellanous utils
-######################
-
-
-## #######
-## # nLoc
-## #######
-## setGeneric("nLoc", function(x,...){
-## standardGeneric("nLoc")
-## })
-
-
-
-## setMethod("nLoc","genind", function(x,...){
-## return(length(x at loc.names))
-## })
-
-
-
-## setMethod("nLoc","genpop", function(x,...){
-## return(length(x at loc.names))
-## })
-
Modified: pkg/man/auxil.Rd
===================================================================
--- pkg/man/auxil.Rd 2009-01-25 14:51:44 UTC (rev 234)
+++ pkg/man/auxil.Rd 2009-01-25 15:19:50 UTC (rev 235)
@@ -3,6 +3,7 @@
\name{Auxiliary functions}
\alias{adegenetWeb}
\alias{adegenetTutorial}
+\alias{checkType}
\alias{.rmspaces}
\alias{.genlab}
\alias{.readExt}
@@ -14,9 +15,11 @@
opens online tutorials for adegenet.\cr
The other functions are:\cr
- - \code{.rmspaces}: remove peripheric spaces in a character string \cr
- - \code{.genlab}: generate labels in a correct alphanumeric ordering \cr
- - \code{.readExt}: read the extension of a given file \cr
+ - \code{checkType}: checks the type of markers being used in a
+ function and issues an error if appropriate.\cr
+ - \code{.rmspaces}: remove peripheric spaces in a character string. \cr
+ - \code{.genlab}: generate labels in a correct alphanumeric ordering. \cr
+ - \code{.readExt}: read the extension of a given file. \cr
}
\usage{
More information about the adegenet-commits
mailing list