[adegenet-commits] r751 - in pkg: R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Jan 5 14:57:03 CET 2011
Author: jombart
Date: 2011-01-05 14:57:03 +0100 (Wed, 05 Jan 2011)
New Revision: 751
Modified:
pkg/R/SNPbin.R
pkg/R/classes.R
pkg/R/handling.R
pkg/man/inbreeding.ml.Rd
Log:
Quite a lot of modif and adds. Added new accessors for all classes. Constructor for genlight working perfectly. Doc is lacking.
Modified: pkg/R/SNPbin.R
===================================================================
--- pkg/R/SNPbin.R 2010-12-26 17:01:34 UTC (rev 750)
+++ pkg/R/SNPbin.R 2011-01-05 13:57:03 UTC (rev 751)
@@ -27,8 +27,8 @@
ind.names = "charOrNULL",
loc.names = "charOrNULL",
loc.all = "charOrNULL",
- ploidy = "integer"),
- prototype(gen = list(), n.loc = integer(0), ind.names = NULL, loc.names = NULL, loc.all = NULL, ploidy = 1L))
+ ploidy = "intOrNULL"),
+ prototype(gen = list(), n.loc = integer(0), ind.names = NULL, loc.names = NULL, loc.all = NULL, ploidy=NULL))
@@ -167,8 +167,13 @@
}
if(is.null(input$loc.names)){
input$loc.names <- colnames(input$gen)
+ if(is.data.frame(input$gen)){ # do not use names if these are the default names of a data.frame
+ if(identical(colnames(input$gen), paste("V", 1:ncol(input$gen), sep=""))){
+ input$loc.names <- NULL
+ }
+ }
}
- input$gen <- lapply(1:nrow(input$gen), function(i) input$gen[i,])
+ input$gen <- lapply(1:nrow(input$gen), function(i) as.integer(input$gen[i,]))
}
@@ -203,13 +208,20 @@
input$ind.names <- as.character(input$ind.names)
## check length consistency
- if(length(input$ind.names) != nInd(x)) stop("Inconsistent length for ind.names.")
+ if(length(input$ind.names) != nInd(x)){
+ stop("Inconsistent length for ind.names.")
+ } else {
+ ## assign value to the output object
+ x at ind.names <- input$ind.names
+ ## ## name list and each SNPbin ## THIS DUPLICATES THE INFORMATION
+ ## names(x at gen) <- input$ind.names
+ ## for(i in 1:length(x at gen)){
+ ## x at gen[[i]]@label <- input$ind.names[i]
+ ## }
- ## ## name list and each SNPbin ## THIS DUPLICATES THE INFORMATION
- ## names(x at gen) <- input$ind.names
- ## for(i in 1:length(x at gen)){
- ## x at gen[[i]]@label <- input$ind.names[i]
- ## }
+ }
+
+
}
@@ -229,12 +241,11 @@
## HANDLE INPUT$PLOIDY ##
+ ## note: if not provided, @ploidy is NULL (saves some space)
if(!is.null(input$ploidy)){ # ploidy is provided
input$ploidy <- as.integer(input$ploidy)
input$ploidy <- rep(input$ploidy, length=length(x at gen))
x at ploidy <- input$ploidy
- } else { # ploidy is not provided
- x at ploidy <- sapply(x at gen, function(e) e at ploidy)
}
@@ -273,6 +284,7 @@
## RETURN OBJECT ##
+ names(x at gen) <- NULL # do not store ind.names twice
return(x)
}) # end genlight constructor
@@ -308,6 +320,29 @@
+
+###############
+## show SNPbin
+###############
+setMethod ("show", "genlight", function(object){
+ cat(" === S4 class genlight ===")
+ cat("\n", nInd(object), "genotypes with", nLoc(object), "binary SNPs")
+ temp <- unique(ploidy(object))
+ if(length(temp)==1){
+ cat("\n Ploidy:", temp)
+ } else {
+ temp <- summary(ploidy(object))
+ cat("\n Ploidy statistics (min/median/max):", temp[1], "/", temp[3], "/", temp[6])
+ }
+ temp <- sapply(object at gen, function(e) length(e at NA.posi))
+ ## temp <- round(length(object at NA.posi)/nLoc(object) *100,2)
+ cat("\n ", sum(temp), " (", round(sum(temp)/(nInd(object)*nLoc(object)),2)," %) missing data\n", sep="")
+}) # end show method
+
+
+
+
+
############
## accessors
############
@@ -346,9 +381,36 @@
})
+setMethod("ploidy","SNPbin", function(x,...){
+ return(x at ploidy)
+})
+setMethod("ploidy","genlight", function(x,...){
+ if(!is.null(x at ploidy)){
+ res <- x at ploidy
+ } else {
+ res <- sapply(x at gen, function(e) e at ploidy)
+ }
+ names(res) <- x at ind.names
+ return(res)
+})
+
+
+
+setMethod("locNames","genlight", function(x,...){
+ return(x at loc.names)
+})
+
+
+setMethod("indNames","genlight", function(x,...){
+ return(x at ind.names)
+})
+
+
+
+
###############
## '[' operators
###############
@@ -459,24 +521,61 @@
}
+setAs("genlight", "matrix", def=function(from){
+ res <- unlist(lapply(from at gen, as.integer))
+ res <- matrix(res, ncol=nLoc(from), nrow=nInd(from), byrow=TRUE)
+ colnames(res) <- locNames(from)
+ rownames(res) <- indNames(from)
+ return(res)
+})
+as.matrix.genlight <- function(x, ...){
+ return(as(x, "matrix"))
+}
+setAs("genlight", "data.frame", def=function(from){
+ return(as.data.frame(as.matrix(from)))
+})
+as.data.frame.genlight <- function(x, ...){
+ return(as(x, "data.frame"))
+}
+setAs("genlight", "list", def=function(from){
+ res <- lapply(from at gen, as.integer)
+ names(res) <- indNames(from)
+ return(res)
+})
+as.list.genlight <- function(x, ...){
+ return(as(x, "list"))
+}
+
+
+
+
+
+
+
+
+
+
+
+
+
################################
-## testing :
+## testing SNPbin
##
##
## library(adegenet)
## HAPLOID DATA - NO NA
-## dat <- sample(c(0,1), 1e6, replace=TRUE)
+## dat <- sample(c(0L,1L), 1e6, replace=TRUE)
## x <- new("SNPbin", dat)
## identical(as(x, "integer"),dat) # SHOULD NORMALLY BE TRUE
## all(as(x, "integer") == dat, na.rm=TRUE) # MUST BE TRUE
@@ -509,3 +608,24 @@
## identical(as(x, "integer"),dat) # MUST BE TRUE
## object.size(dat)/object.size(x) # EFFICIENCY OF CONVERSION
+
+
+
+
+################################
+## testing genlight
+##
+##
+
+
+## SIMPLE TEST
+library(adegenet)
+dat <- list(toto=c(1,1,0), titi=c(NA,1,1,0), tata=c(NA,0,3, NA))
+x <- new("genlight", dat)
+x
+as.list(x)
+as.matrix(x)
+
+identical(x, new("genlight", as.list(x))) # round trip - list - MUST BE TRUE
+identical(x, new("genlight", as.matrix(x))) # round trip - matrix - MUST BE TRUE
+identical(x, new("genlight", as.data.frame(x))) # round trip - data.frame - MUST BE TRUE
Modified: pkg/R/classes.R
===================================================================
--- pkg/R/classes.R 2010-12-26 17:01:34 UTC (rev 750)
+++ pkg/R/classes.R 2011-01-05 13:57:03 UTC (rev 751)
@@ -40,9 +40,9 @@
setClassUnion("charOrNULL", c("character","NULL"))
setClassUnion("callOrNULL", c("call","NULL"))
setClassUnion("intOrNum", c("integer","numeric","NULL"))
+setClassUnion("intOrNULL", c("integer","NULL"))
-
####################
# virtual class gen
####################
Modified: pkg/R/handling.R
===================================================================
--- pkg/R/handling.R 2010-12-26 17:01:34 UTC (rev 750)
+++ pkg/R/handling.R 2011-01-05 13:57:03 UTC (rev 751)
@@ -618,3 +618,46 @@
return(res)
})
+
+
+
+###########
+# indNames
+###########
+setGeneric("indNames", function(x,...){
+ standardGeneric("indNames")
+})
+
+
+
+setMethod("indNames","genind", function(x, ...){
+ return(x at ind.names)
+})
+
+
+
+
+
+
+
+#######
+# ploidy
+#######
+setGeneric("ploidy", function(x,...){
+ standardGeneric("ploidy")
+})
+
+
+
+setMethod("ploidy","genind", function(x,...){
+ return(nrow(x at ploidy))
+})
+
+
+
+setMethod("ploidy","genpop", function(x,...){
+ return(nrow(x at ploidy))
+})
+
+
+
Modified: pkg/man/inbreeding.ml.Rd
===================================================================
--- pkg/man/inbreeding.ml.Rd 2010-12-26 17:01:34 UTC (rev 750)
+++ pkg/man/inbreeding.ml.Rd 2011-01-05 13:57:03 UTC (rev 751)
@@ -85,3 +85,5 @@
## plot the first 10 functions
invisible(sapply(Fdens[1:10], plot, ylab="Density", main="Density of probability of F values"))
+
+}
\ No newline at end of file
More information about the adegenet-commits
mailing list