[adegenet-commits] r818 - pkg/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Feb 24 11:35:32 CET 2011
Author: jombart
Date: 2011-02-24 11:35:32 +0100 (Thu, 24 Feb 2011)
New Revision: 818
Modified:
pkg/R/SNPbin.R
pkg/R/handling.R
Log:
Added "other" generic + methods for genind, genpop and genlight.
Replacement methods included.
Changed the printing of genlight objects.
Implementing the treatment of @other for [ procedure - still not working.
Need to document new accessors.
Modified: pkg/R/SNPbin.R
===================================================================
--- pkg/R/SNPbin.R 2011-02-21 18:17:19 UTC (rev 817)
+++ pkg/R/SNPbin.R 2011-02-24 10:35:32 UTC (rev 818)
@@ -149,6 +149,7 @@
x <- .Object
input <- list(...)
if(length(input)==1 && is.null(names(input))) names(input) <- "gen"
+ if(length(input)>1 && ! "gen" %in% names(input)) names(input)[1] <- "gen"
## HANDLE INPUT$GEN ##
@@ -362,7 +363,7 @@
###############
setMethod ("show", "genlight", function(object){
cat(" === S4 class genlight ===")
- cat("\n", nInd(object), "genotypes with", nLoc(object), "binary SNPs")
+ cat("\n", nInd(object), "genotypes, ", nLoc(object), "binary SNPs")
temp <- unique(ploidy(object))
if(!is.null(temp)){
if(length(temp)==1){
@@ -376,6 +377,14 @@
if(length(temp>1)){
cat("\n ", sum(temp), " (", round(sum(temp)/(nInd(object)*nLoc(object)),2)," %) missing data", sep="")
}
+
+ if(!is.null(other(x))){
+ cat("\n Other: ")
+ cat("a list containing ")
+ cat(ifelse(is.null(names(other(x))), paste(length(other(x)),"unnamed elements"),
+ paste(names(other(x)), collapse= " ")), "\n")
+ }
+
cat("\n")
}) # end show method
@@ -383,6 +392,7 @@
+
############
## accessors
############
@@ -567,8 +577,23 @@
+## other
+setMethod("other","genlight", function(x,...){
+ if(length(x at other)==0) return(NULL)
+ return(x at other)
+})
+setReplaceMethod("other","genlight",function(x,value) {
+ if( !is.null(value) && (!is.list(value) | is.data.frame(value)) ) {
+ value <- list(value)
+ }
+ slot(x,"other",check=TRUE) <- value
+ return(x)
+})
+
+
+
###############
## '[' operators
###############
@@ -583,8 +608,8 @@
-
-setMethod("[", signature(x="genlight", i="ANY", j="ANY", drop="ANY"), function(x, i, j, ...) {
+## genlight
+setMethod("[", signature(x="genlight", i="ANY", j="ANY", drop="ANY"), function(x, i, j, ..., treatOther=TRUE, drop=FALSE) {
if (missing(i)) i <- TRUE
if (missing(j)) j <- TRUE
@@ -604,8 +629,30 @@
x <- as.matrix(x)[, j, drop=FALSE] # maybe need to process one row at a time
x <- new("genlight", gen=x, ploidy=ori.ploidy)
}
+
+ ## HANDLE 'OTHER' SLOT ##
+ nOther <- length(x at other)
+ namesOther <- names(x at other)
+ counter <- 0
+ if(treatOther){
+ f1 <- function(obj,n=nInd(x)){
+ 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(x)
-}) # end [] for SNPbin
+}) # end [] for genlight
@@ -941,7 +988,7 @@
-## c, cbind, rbind:
+## 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]
@@ -949,3 +996,9 @@
## 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)))
Modified: pkg/R/handling.R
===================================================================
--- pkg/R/handling.R 2011-02-21 18:17:19 UTC (rev 817)
+++ pkg/R/handling.R 2011-02-24 10:35:32 UTC (rev 818)
@@ -226,6 +226,26 @@
+## genlight
+setMethod("seppop", signature(x="genlight"), function(x, pop=NULL, treatOther=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), function(lev) x[pop==lev, , treatOther=treatOther])
+ names(kObj) <- levels(pop)
+
+ return(kObj)
+})
+
+
+
+
#####################
# Methods na.replace
#####################
@@ -705,9 +725,9 @@
-#######
-# ploidy
-#######
+##########
+## ploidy
+##########
setGeneric("ploidy", function(x,...){
standardGeneric("ploidy")
})
@@ -717,7 +737,7 @@
})
setMethod("ploidy","genind", function(x,...){
- return(nrow(x at ploidy))
+ return(x at ploidy)
})
@@ -732,11 +752,11 @@
setMethod("ploidy","genpop", function(x,...){
- return(nrow(x at ploidy))
+ return(x at ploidy)
})
-setReplaceMethod("ploidy","genind",function(x,value) {
+setReplaceMethod("ploidy","genpop",function(x,value) {
value <- as.integer(value)
if(any(value)<1) stop("Negative or null values provided")
if(any(is.na(value))) stop("NA values provided")
@@ -746,3 +766,48 @@
})
+
+
+
+
+##########
+## other
+#########
+setGeneric("other", function(x,...){
+ standardGeneric("other")
+})
+
+setGeneric("other<-", function(x, value){
+ standardGeneric("other<-")
+})
+
+setMethod("other","genind", function(x,...){
+ if(length(x at other)==0) return(NULL)
+ return(x at other)
+})
+
+
+setReplaceMethod("other","genind",function(x,value) {
+ if( !is.null(value) && (!is.list(value) | is.data.frame(value)) ) {
+ value <- list(value)
+ }
+ slot(x,"other",check=TRUE) <- value
+ return(x)
+})
+
+
+setMethod("other","genpop", function(x,...){
+ if(length(x at other)==0) return(NULL)
+ return(x at other)
+})
+
+
+setReplaceMethod("other","genpop",function(x,value) {
+ if( !is.null(value) && (!is.list(value) | is.data.frame(value)) ) {
+ value <- list(value)
+ }
+ slot(x,"other",check=TRUE) <- value
+ return(x)
+})
+
+
More information about the adegenet-commits
mailing list