[adegenet-commits] r823 - pkg/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Feb 25 16:28:27 CET 2011
Author: jombart
Date: 2011-02-25 16:28:27 +0100 (Fri, 25 Feb 2011)
New Revision: 823
Added:
pkg/R/glHandle.R
Modified:
pkg/R/SNPbin.R
pkg/R/glFunctions.R
Log:
Reorganised source files:
- SNPbin.R: class def and accessors
- glHandle.R: handling on SNPbin/genlight
- glFunctions: computing stuff on genlight
Modified: pkg/R/SNPbin.R
===================================================================
--- pkg/R/SNPbin.R 2011-02-24 15:32:20 UTC (rev 822)
+++ pkg/R/SNPbin.R 2011-02-25 15:28:27 UTC (rev 823)
@@ -598,184 +598,11 @@
-###############
-## '[' operators
-###############
-## SNPbin
-setMethod("[", signature(x="SNPbin", i="ANY"), function(x, i) {
- if (missing(i)) i <- TRUE
- temp <- .SNPbin2int(x) # data as integers with NAs
- x <- new("SNPbin", snp=temp[i], label=x at label, ploidy=x at ploidy)
- return(x)
-}) # end [] for SNPbin
-## genlight
-setMethod("[", signature(x="genlight", i="ANY", j="ANY", drop="ANY"), function(x, i, j, ..., treatOther=TRUE, quiet=TRUE, drop=FALSE) {
- if (missing(i)) i <- TRUE
- if (missing(j)) j <- TRUE
- ori.n <- nInd(x)
-
-
- ## SUBSET INDIVIDUALS ##
- x at gen <- x at gen[i]
- x at ind.names <- x at ind.names[i]
- if(!is.null(x at ploidy)) {
- ori.ploidy <- ploidy(x)[i]
- } else {
- ori.ploidy <- NULL
- }
-
- ## HANDLE 'OTHER' SLOT ##
- nOther <- length(other(x))
- namesOther <- names(other(x))
- counter <- 0
- if(treatOther & !(is.logical(i) && all(i))){
- f1 <- function(obj,n=ori.n){
- counter <<- counter+1
- if(!is.null(dim(obj)) && nrow(obj)==ori.n) { # if the element is a matrix-like obj
- obj <- obj[i,,drop=FALSE]
- } else if(length(obj) == ori.n) { # if the element is not a matrix but has a length == n
- obj <- obj[i]
- if(is.factor(obj)) {obj <- factor(obj)}
- } else {if(!quiet) warning(paste("cannot treat the object",namesOther[counter]))}
-
- return(obj)
- } # end f1
-
- other(x) <- lapply(x at other, f1) # treat all elements
-
- } # end treatOther
-
-
- ## SUBSET LOCI ##
- if(length(j)==1 && is.logical(j) && j){ # no need to subset SNPs
- return(x)
- } else { # need to subset SNPs
- old.other <- other(x)
- x <- as.matrix(x)[, j, drop=FALSE] # maybe need to process one row at a time
- x <- new("genlight", gen=x, ploidy=ori.ploidy, other=old.other)
- }
-
- return(x)
-}) # end [] for genlight
-
-
-
-
-
-
-
-######################
-##
-## c, cbind, rbind...
-##
-######################
-
-################
-## cbind SNPbin
-################
-##setMethod("cbind", signature("SNPbin"), function(..., deparse.level = 1) {
-cbind.SNPbin <- function(...){
- myList <- list(...)
- if(!all(sapply(myList, class)=="SNPbin")) stop("some objects are not SNPbin objects")
- if(length(unique(sapply(myList, ploidy))) !=1 ) stop("objects have different ploidy levels")
- x <- new("SNPbin", unlist(lapply(myList, as.integer)))
- return(x)
-} # end cbind.SNPbin
-##})
-
-
-
-c.SNPbin <- function(...){
- return(cbind(...))
-}
-
-
-
-##################
-## cbind genlight
-##################
-##setMethod("cbind", signature(x="genlight"), function(..., deparse.level = 1) {
-cbind.genlight <- function(...){
- myList <- list(...)
- if(!all(sapply(myList, class)=="genlight")) stop("some objects are not genlight objects")
- if(length(unique(sapply(myList, nInd))) !=1 ) stop("objects have different numbers of individuals")
- n.obj <- length(myList)
- n.ind <- nInd(myList[[1]])
-
- ## merge one individual at a time ##
- res <- list()
- for(i in 1:n.ind){
- res[[i]] <- Reduce(cbind, lapply(myList, function(e) e at gen[[i]]))
- }
-
- res <- new("genlight",res)
-
- ## handle loc.names, alleles, etc. ##
- indNames(res) <- indNames(myList[[1]])
- locNames(res) <- unlist(lapply(myList, locNames))
- alleles(res) <- unlist(lapply(myList, alleles))
- pop(res) <- pop(myList[[1]])
-
- ## return object ##
- return(res)
-} # end cbind.genlight
-##})
-
-
-
-
-
-
-##################
-## rbind genlight
-##################
-##setMethod("cbind", signature(x="genlight"), function(..., deparse.level = 1) {
-rbind.genlight <- function(...){
- myList <- list(...)
- if(!all(sapply(myList, class)=="genlight")) stop("some objects are not genlight objects")
- if(length(unique(sapply(myList, nLoc))) !=1 ) stop("objects have different numbers of SNPs")
-
- ## build output
- res <- new("genlight", Reduce(c, lapply(myList, function(e) e at gen)))
- locNames(res) <- locNames(myList[[1]])
- alleles(res) <- alleles(myList[[1]])
- indNames(res) <- unlist(lapply(myList, indNames))
- pop(res) <- factor(unlist(lapply(myList, pop)))
-
- ## return object ##
- return(res)
-
-} # end rbind.genlight
-
-
-
-##########
-## seppop
-##########
-setMethod("seppop", signature(x="genlight"), function(x, pop=NULL, treatOther=TRUE, quiet=TRUE){
- ## HANDLE POP ARGUMENT ##
- if(!is.null(pop)) {
- pop(x) <- pop
- }
-
- if(is.null(pop(x))) stop("pop not provided and pop(x) is NULL")
-
- ## PERFORM SUBSETTING ##
- kObj <- lapply(levels(pop(x)), function(lev) x[pop(x)==lev, , treatOther=treatOther, quiet=quiet])
- names(kObj) <- levels(pop(x))
-
- return(kObj)
-})
-
-
-
-
-
###################
##
## CONVERSIONS
Modified: pkg/R/glFunctions.R
===================================================================
--- pkg/R/glFunctions.R 2011-02-24 15:32:20 UTC (rev 822)
+++ pkg/R/glFunctions.R 2011-02-25 15:28:27 UTC (rev 823)
@@ -500,6 +500,8 @@
} # end loadingplot.glPca
+
+
## TESTING ##
## x <- new("genlight", list(c(0,0,1,1,0), c(1,1,1,0,0,1), c(2,1,1,1,1,NA)))
## as.matrix(x)
Added: pkg/R/glHandle.R
===================================================================
--- pkg/R/glHandle.R (rev 0)
+++ pkg/R/glHandle.R 2011-02-25 15:28:27 UTC (rev 823)
@@ -0,0 +1,210 @@
+
+###############
+## '[' operators
+###############
+## SNPbin
+setMethod("[", signature(x="SNPbin", i="ANY"), function(x, i) {
+ if (missing(i)) i <- TRUE
+ temp <- .SNPbin2int(x) # data as integers with NAs
+ x <- new("SNPbin", snp=temp[i], label=x at label, ploidy=x at ploidy)
+ return(x)
+}) # end [] for SNPbin
+
+
+
+
+## genlight
+setMethod("[", signature(x="genlight", i="ANY", j="ANY", drop="ANY"), function(x, i, j, ..., treatOther=TRUE, quiet=TRUE, drop=FALSE) {
+ if (missing(i)) i <- TRUE
+ if (missing(j)) j <- TRUE
+
+ ori.n <- nInd(x)
+
+
+ ## SUBSET INDIVIDUALS ##
+ x at gen <- x at gen[i]
+ x at ind.names <- x at ind.names[i]
+ if(!is.null(x at ploidy)) {
+ ori.ploidy <- ploidy(x)[i]
+ } else {
+ ori.ploidy <- NULL
+ }
+
+ ## HANDLE 'OTHER' SLOT ##
+ nOther <- length(other(x))
+ namesOther <- names(other(x))
+ counter <- 0
+ if(treatOther & !(is.logical(i) && all(i))){
+ f1 <- function(obj,n=ori.n){
+ counter <<- counter+1
+ if(!is.null(dim(obj)) && nrow(obj)==ori.n) { # if the element is a matrix-like obj
+ obj <- obj[i,,drop=FALSE]
+ } else if(length(obj) == ori.n) { # if the element is not a matrix but has a length == n
+ obj <- obj[i]
+ if(is.factor(obj)) {obj <- factor(obj)}
+ } else {if(!quiet) warning(paste("cannot treat the object",namesOther[counter]))}
+
+ return(obj)
+ } # end f1
+
+ other(x) <- lapply(x at other, f1) # treat all elements
+
+ } # end treatOther
+
+
+ ## SUBSET LOCI ##
+ if(length(j)==1 && is.logical(j) && j){ # no need to subset SNPs
+ return(x)
+ } else { # need to subset SNPs
+ old.other <- other(x)
+ x <- as.matrix(x)[, j, drop=FALSE] # maybe need to process one row at a time
+ x <- new("genlight", gen=x, ploidy=ori.ploidy, other=old.other)
+ }
+
+ return(x)
+}) # end [] for genlight
+
+
+
+
+
+
+
+######################
+##
+## c, cbind, rbind...
+##
+######################
+
+################
+## cbind SNPbin
+################
+##setMethod("cbind", signature("SNPbin"), function(..., deparse.level = 1) {
+cbind.SNPbin <- function(...){
+ myList <- list(...)
+ if(!all(sapply(myList, class)=="SNPbin")) stop("some objects are not SNPbin objects")
+ if(length(unique(sapply(myList, ploidy))) !=1 ) stop("objects have different ploidy levels")
+ x <- new("SNPbin", unlist(lapply(myList, as.integer)))
+ return(x)
+} # end cbind.SNPbin
+##})
+
+
+
+c.SNPbin <- function(...){
+ return(cbind(...))
+}
+
+
+
+
+##################
+## cbind genlight
+##################
+##setMethod("cbind", signature(x="genlight"), function(..., deparse.level = 1) {
+cbind.genlight <- function(...){
+ myList <- list(...)
+ if(!all(sapply(myList, class)=="genlight")) stop("some objects are not genlight objects")
+ if(length(unique(sapply(myList, nInd))) !=1 ) stop("objects have different numbers of individuals")
+ n.obj <- length(myList)
+ n.ind <- nInd(myList[[1]])
+
+ ## merge one individual at a time ##
+ res <- list()
+ for(i in 1:n.ind){
+ res[[i]] <- Reduce(cbind, lapply(myList, function(e) e at gen[[i]]))
+ }
+
+ res <- new("genlight",res)
+
+ ## handle loc.names, alleles, etc. ##
+ indNames(res) <- indNames(myList[[1]])
+ locNames(res) <- unlist(lapply(myList, locNames))
+ alleles(res) <- unlist(lapply(myList, alleles))
+ pop(res) <- pop(myList[[1]])
+
+ ## return object ##
+ return(res)
+} # end cbind.genlight
+##})
+
+
+
+
+
+
+##################
+## rbind genlight
+##################
+##setMethod("cbind", signature(x="genlight"), function(..., deparse.level = 1) {
+rbind.genlight <- function(...){
+ myList <- list(...)
+ if(!all(sapply(myList, class)=="genlight")) stop("some objects are not genlight objects")
+ if(length(unique(sapply(myList, nLoc))) !=1 ) stop("objects have different numbers of SNPs")
+
+ ## build output
+ res <- new("genlight", Reduce(c, lapply(myList, function(e) e at gen)))
+ locNames(res) <- locNames(myList[[1]])
+ alleles(res) <- alleles(myList[[1]])
+ indNames(res) <- unlist(lapply(myList, indNames))
+ pop(res) <- factor(unlist(lapply(myList, pop)))
+
+ ## return object ##
+ return(res)
+
+} # end rbind.genlight
+
+
+
+
+
+
+##########
+## seppop
+##########
+setMethod("seppop", signature(x="genlight"), function(x, pop=NULL, treatOther=TRUE, quiet=TRUE){
+ ## HANDLE POP ARGUMENT ##
+ if(!is.null(pop)) {
+ pop(x) <- pop
+ }
+
+ if(is.null(pop(x))) stop("pop not provided and pop(x) is NULL")
+
+ ## PERFORM SUBSETTING ##
+ kObj <- lapply(levels(pop(x)), function(lev) x[pop(x)==lev, , treatOther=treatOther, quiet=quiet])
+ names(kObj) <- levels(pop(x))
+
+ return(kObj)
+})
+
+
+
+
+
+
+
+
+
+
+
+
+###################
+### TESTING
+###################
+
+
+## c, cbind, rbind ##
+## a <- new("genlight", list(c(1,0,1), c(0,0,1,0)) )
+## b <- new("genlight", list(c(1,0,1,1,1,1), c(1,0)) )
+## locNames(a) <- letters[1:4]
+## locNames(b) <- 1:6
+## c <- cbind(a,b)
+## identical(as.matrix(c),cbind(as.matrix(a), as.matrix(b))) # MUST BE TRUE
+## identical(as.matrix(rbind(a,a)),rbind(as.matrix(a),as.matrix(a)))
+
+
+
+
+## test subsetting with/without @other ##
+## x <- new("genlight", list(a=1,b=0,c=1), other=list(1:3, letters, data.frame(2:4)))
+## pop(x) <- c("pop1","pop1", "pop2")
More information about the adegenet-commits
mailing list