[adegenet-commits] r641 - pkg/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri May 21 14:30:26 CEST 2010
Author: jombart
Date: 2010-05-21 14:30:25 +0200 (Fri, 21 May 2010)
New Revision: 641
Modified:
pkg/R/basicMethods.R
pkg/R/handling.R
Log:
another try...
Modified: pkg/R/basicMethods.R
===================================================================
--- pkg/R/basicMethods.R 2010-05-21 12:23:51 UTC (rev 640)
+++ pkg/R/basicMethods.R 2010-05-21 12:30:25 UTC (rev 641)
@@ -1,3 +1,147 @@
+
+
+
+
+
+
+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]
+
+ if(drop){
+ allNb <- apply(tab, 2, sum, na.rm=TRUE) # allele absolute frequencies
+ toKeep <- (allNb > 1e-10)
+ tab <- tab[,toKeep, drop=FALSE]
+ }
+
+ res <- genind(tab,pop=pop,prevcall=prevcall, ploidy=x at ploidy, type=x at type)
+
+ ## 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]
+
+ if(drop){
+ allNb <- apply(tab, 2, sum, na.rm=TRUE) # allele absolute frequencies
+ toKeep <- (allNb > 1e-10)
+ tab <- tab[,toKeep, 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)
+ })
+
+
+
+
##########################
# Method show for genind
##########################
Modified: pkg/R/handling.R
===================================================================
--- pkg/R/handling.R 2010-05-21 12:23:51 UTC (rev 640)
+++ pkg/R/handling.R 2010-05-21 12:30:25 UTC (rev 641)
@@ -6,150 +6,6 @@
# T. Jombart
###########################
-
-
-
-
-
-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]
-
- if(drop){
- allNb <- apply(tab, 2, sum, na.rm=TRUE) # allele absolute frequencies
- toKeep <- (allNb > 1e-10)
- tab <- tab[,toKeep, drop=FALSE]
- }
-
- res <- genind(tab,pop=pop,prevcall=prevcall, ploidy=x at ploidy, type=x at type)
-
- ## 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]
-
- if(drop){
- allNb <- apply(tab, 2, sum, na.rm=TRUE) # allele absolute frequencies
- toKeep <- (allNb > 1e-10)
- tab <- tab[,toKeep, 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)
- })
-
-
-
-
-
##############################
# Method truenames for genind
##############################
More information about the adegenet-commits
mailing list