[adegenet-commits] r819 - in pkg: R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Feb 24 13:44:47 CET 2011
Author: jombart
Date: 2011-02-24 13:44:47 +0100 (Thu, 24 Feb 2011)
New Revision: 819
Modified:
pkg/R/SNPbin.R
pkg/R/basicMethods.R
pkg/R/handling.R
pkg/man/accessors.Rd
pkg/man/genlight.Rd
pkg/man/seppop.Rd
Log:
Lots of stuff.
Fixes to some accessors.
seppop works for genlight
subsetting of @other is OK.
Documented.
Modified: pkg/R/SNPbin.R
===================================================================
--- pkg/R/SNPbin.R 2011-02-24 10:35:32 UTC (rev 818)
+++ pkg/R/SNPbin.R 2011-02-24 12:44:47 UTC (rev 819)
@@ -378,11 +378,15 @@
cat("\n ", sum(temp), " (", round(sum(temp)/(nInd(object)*nLoc(object)),2)," %) missing data", sep="")
}
- if(!is.null(other(x))){
- cat("\n Other: ")
+ if(!is.null(pop(object))){
+ cat("\n @pop: individual membership for", length(levels(pop(object))), "populations\n")
+ }
+
+ if(!is.null(other(object))){
+ cat(" @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(ifelse(is.null(names(other(object))), paste(length(other(object)),"unnamed elements"),
+ paste(names(other(object)), collapse= " ")), "\n")
}
cat("\n")
@@ -609,10 +613,13 @@
## genlight
-setMethod("[", signature(x="genlight", i="ANY", j="ANY", drop="ANY"), function(x, i, j, ..., treatOther=TRUE, drop=FALSE) {
+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]
@@ -622,35 +629,37 @@
ori.ploidy <- NULL
}
- ## SUBSET LOCI ##
- if(length(j)==1 && is.logical(j) && j){ # no need to subset SNPs
- return(x)
- } else { # need to subset SNPs
- 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)
+ nOther <- length(other(x))
+ namesOther <- names(other(x))
counter <- 0
- if(treatOther){
- f1 <- function(obj,n=nInd(x)){
+ if(treatOther & !(is.logical(i) && all(i))){
+ f1 <- function(obj,n=ori.n){
counter <<- counter+1
- if(!is.null(dim(obj)) && nrow(obj)==n) { # if the element is a matrix-like obj
+ 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) == n) { # if the element is not a matrix but has a length == n
+ } 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 {warning(paste("cannot treat the object",namesOther[counter]))}
+ } else {if(!quiet) warning(paste("cannot treat the object",namesOther[counter]))}
return(obj)
} # end f1
- res at other <- lapply(x at other, f1) # treat all elements
+ 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
@@ -745,8 +754,28 @@
+##########
+## 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
@@ -1002,3 +1031,4 @@
## 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")
Modified: pkg/R/basicMethods.R
===================================================================
--- pkg/R/basicMethods.R 2011-02-24 10:35:32 UTC (rev 818)
+++ pkg/R/basicMethods.R 2011-02-24 12:44:47 UTC (rev 819)
@@ -18,128 +18,135 @@
# '[' operator
###############
## genind
-setMethod("[", signature(x="genind", i="ANY", j="ANY", drop="ANY"), function(x, i, j, ..., loc=NULL, treatOther=TRUE, drop=FALSE) {
+setMethod("[", signature(x="genind", i="ANY", j="ANY", drop="ANY"), function(x, i, j, ..., loc=NULL, treatOther=TRUE, quiet=TRUE, drop=FALSE) {
- if (missing(i)) i <- TRUE
- if (missing(j)) j <- TRUE
+ 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])
- }
+ 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
+ old.other <- other(x)
- prevcall <- match.call()
+ ## 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
- tab <- tab[i, j, ...,drop=FALSE]
+ prevcall <- match.call()
- if(drop){
- allNb <- apply(tab, 2, sum, na.rm=TRUE) # allele absolute frequencies
- toKeep <- (allNb > 1e-10)
- tab <- tab[,toKeep, drop=FALSE]
- }
+ tab <- tab[i, j, ...,drop=FALSE]
- res <- genind(tab,pop=pop,prevcall=prevcall, ploidy=x at ploidy, type=x at type)
+ if(drop){
+ allNb <- apply(tab, 2, sum, na.rm=TRUE) # allele absolute frequencies
+ toKeep <- (allNb > 1e-10)
+ tab <- tab[,toKeep, drop=FALSE]
+ }
- ## 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]))}
+ res <- genind(tab,pop=pop,prevcall=prevcall, ploidy=x at ploidy, type=x at type)
- return(obj)
- } # end f1
+ ## 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 {if(!quiet) warning(paste("cannot treat the object",namesOther[counter]))}
- res at other <- lapply(x at other, f1) # treat all elements
+ return(obj)
+ } # end f1
- } # end treatOther
+ res at other <- lapply(x at other, f1) # treat all elements
- return(res)
- })
+ } else {
+ other(res) <- old.other
+ } # end treatOther
+ return(res)
+})
+
## genpop
-setMethod("[", "genpop",
- function(x, i, j, ..., loc=NULL, treatOther=TRUE, drop=FALSE) {
+setMethod("[", "genpop", function(x, i, j, ..., loc=NULL, treatOther=TRUE, drop=FALSE) {
- if (missing(i)) i <- TRUE
- if (missing(j)) j <- TRUE
+ if (missing(i)) i <- TRUE
+ if (missing(j)) j <- TRUE
- tab <- truenames(x)
+ tab <- truenames(x)
+ old.other <- other(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]
+ ## 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
- if(drop){
- allNb <- apply(tab, 2, sum, na.rm=TRUE) # allele absolute frequencies
- toKeep <- (allNb > 1e-10)
- tab <- tab[,toKeep, drop=FALSE]
- }
+ prevcall <- match.call()
+ tab <- tab[i, j, ...,drop=FALSE]
- res <- genpop(tab,prevcall=prevcall)
+ if(drop){
+ allNb <- apply(tab, 2, sum, na.rm=TRUE) # allele absolute frequencies
+ toKeep <- (allNb > 1e-10)
+ tab <- tab[,toKeep, drop=FALSE]
+ }
- ## 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]))}
+ res <- genpop(tab,prevcall=prevcall)
- return(obj)
- } # end f1
+ ## 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]))}
- res at other <- lapply(x at other, f1) # treat all elements
+ return(obj)
+ } # end f1
- } # end treatOther
+ res at other <- lapply(x at other, f1) # treat all elements
+ } else {
+ other(res) <- old.other
+ } # end treatOther
- return(res)
- })
+ return(res)
+})
+
##########################
# Method show for genind
##########################
Modified: pkg/R/handling.R
===================================================================
--- pkg/R/handling.R 2011-02-24 10:35:32 UTC (rev 818)
+++ pkg/R/handling.R 2011-02-24 12:44:47 UTC (rev 819)
@@ -186,7 +186,7 @@
setGeneric("seppop", function(x, ...) standardGeneric("seppop"))
## genind
-setMethod("seppop", signature(x="genind"), function(x,pop=NULL,truenames=TRUE,res.type=c("genind","matrix"), drop=FALSE, treatOther=TRUE){
+setMethod("seppop", signature(x="genind"), function(x,pop=NULL,truenames=TRUE,res.type=c("genind","matrix"), drop=FALSE, treatOther=TRUE, quiet=TRUE){
## checkType(x)
## misc checks
@@ -206,7 +206,7 @@
## 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, , drop=drop, treatOther=treatOther])
+ kObj <- lapply(levels(pop), function(lev) x[pop==lev, , drop=drop, treatOther=treatOther, quiet=quiet])
names(kObj) <- levels(pop)
## res is a list of genind
@@ -226,26 +226,8 @@
-## 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
#####################
Modified: pkg/man/accessors.Rd
===================================================================
--- pkg/man/accessors.Rd 2011-02-24 10:35:32 UTC (rev 818)
+++ pkg/man/accessors.Rd 2011-02-24 12:44:47 UTC (rev 819)
@@ -38,6 +38,13 @@
\alias{alleles<-}
\alias{alleles<-,genind-method}
\alias{alleles<-,genpop-method}
+\alias{other}
+\alias{other,genind-method}
+\alias{other,genpop-method}
+\alias{other<-}
+\alias{other<-,genind-method}
+\alias{other<-,genpop-method}
+
\title{Accessors for adegenet objects}
\description{
An accessor is a function that allows to interact with slots of an
@@ -87,6 +94,12 @@
\item{alleles}{returns the alleles of each locus.}
\item{alleles<-}{sets the alleles of each locus using a list with
one character vector for each locus.}
+ \item{other}{returns the content of the \code{@other} slot
+ (misc. information); returns \code{NULL} if the slot is empty or of
+ length zero.}
+ \item{other<-}{sets the content of the \code{@other} slot
+ (misc. information); the provided value needs to be a list; it
+ not, provided value will be stored within a list.}
}
}
\usage{
@@ -101,6 +114,8 @@
ploidy(x, \dots)
\S4method{ploidy}{genind}(x, \dots)
\S4method{ploidy}{genpop}(x, \dots)
+\S4method{other}{genind}(x, \dots)
+\S4method{other}{genpop}(x, \dots)
}
\arguments{
\item{x}{a \linkS4class{genind} or a \linkS4class{genpop} object.}
@@ -119,12 +134,12 @@
coordinates, the \code{obj[1:3,]@other$xy} will contain the spatial
coordinates of the genotypes (or population) 1,2 and 3. This is
handled through the argument \code{treatOther}, a logical defaulting
- to TRUE. If set to FALSE, the \code{@other} component is not
- returned.\cr
+ to TRUE. If set to FALSE, the \code{@other} returned unmodified.\cr
Note that only matrix-like, vector-like and lists can be proceeded in
\code{@other}. Other kind of objects will issue a warning an be
- returned as they are.\cr
+ returned as they are, unless the argument \code{quiet} is left to
+ TRUE, its default value.\cr
The \code{drop} argument can be set to TRUE to retain only alleles
that are present in the subset. To achieve better control of
@@ -133,30 +148,34 @@
\examples{
data(nancycats)
nancycats
-nancycats$pop
+pop(nancycats) # get the populations
+indNames(nancycats) # get the labels of individuals
+locNames(nancycats) # get the labels of the loci
+alleles(nancycats) # get the alleles
# let's isolate populations 4 and 8
temp <- nancycats at pop=="P04" | nancycats at pop=="P08"
obj <- nancycats[temp,]
obj
-truenames(obj)$pop
+pop(obj)
# let's isolate two markers, fca23 and fca90
-nancycats$loc.names
+locNames(nancycats)
# they correspond to L2 and L7
+nancycats$loc.fac
temp <- nancycats$loc.fac=="L2" | nancycats$loc.fac=="L7"
obj <- nancycats[,temp]
obj
-obj$loc.fac
-obj$loc.names
+obj$loc.fac
+locNames(obj)
# or more simply
nancycats[loc=c("L2","L7")]
obj$loc.fac
-obj$loc.names
+locNames(obj)
# using 'drop':
truenames(nancycats[1:2])$tab
Modified: pkg/man/genlight.Rd
===================================================================
--- pkg/man/genlight.Rd 2011-02-24 10:35:32 UTC (rev 818)
+++ pkg/man/genlight.Rd 2011-02-24 12:44:47 UTC (rev 819)
@@ -111,8 +111,9 @@
\describe{
\item{[}{\code{signature(x = "genlight")}: usual method to subset
objects in R. Is to be applied as if the object was a matrix where
- genotypes are rows and SNPs are columns. Indexing can be done via
- vectors of signed integers or of logicals.}
+ genotypes were rows and SNPs were columns. Indexing can be done via
+ vectors of signed integers or of logicals. See details for extra
+ supported arguments.}
\item{show}{\code{signature(x = "genlight")}: printing of the
object.}
\item{$}{\code{signature(x = "genlight")}: similar to the @ operator;
@@ -166,6 +167,22 @@
different individuals genotyped for the same SNPs.}
}
}
+\details{
+ === On the subsetting using \code{[} ===
+ The function \code{[} accepts the following extra arguments:
+ \describe{
+ \item{treatOther}{a logical stating whether elements of the
+ \code{@other} slot should be treated as well (TRUE), or not
+ (FALSE). If treated, elements of the list are examined for a
+ possible match of length (vectors, lists) or number of rows
+ (matrices, data frames) with the number of individuals. Those who
+ match are subsetted accordingly. Others are left as is, issuing a
+ warning unless the argument \code{quiet} is set to TRUE.}
+ \item{quiet}{a logical indicating whether warnings should be issued
+ when trying to subset components of the \code{@other} slot which
+ do not match the number of individuals (TRUE), or not (FALSE, default). }
+ }
+}
\author{Thibaut Jombart (\email{t.jombart at imperial.ac.uk})}
\seealso{
Related class:\cr
@@ -226,5 +243,22 @@
aca <- cbind(a,a)
aca
as.matrix(aca)
+
+
+#### subsetting @other ####
+x <- new("genlight", list(a=1,b=0,c=1), other=list(1:3, letters,data.frame(2:4)))
+x
+other(x)
+x[2:3]
+other(x[2:3])
+other(x[2:3, treatOther=FALSE])
+
+
+#### seppop ####
+pop(x) # no population info
+pop(x) <- c("pop1","pop1", "pop2") # set population memberships
+pop(x)
+seppop(x)
+
}
\keyword{classes}
Modified: pkg/man/seppop.Rd
===================================================================
--- pkg/man/seppop.Rd 2011-02-24 10:35:32 UTC (rev 818)
+++ pkg/man/seppop.Rd 2011-02-24 12:44:47 UTC (rev 819)
@@ -5,18 +5,22 @@
\alias{seppop-methods}
\alias{seppop,ANY-method}
\alias{seppop,genind-method}
+\alias{seppop,genlight-method}
\title{ Separate genotypes per population}
\description{
- The function \code{seppop} splits a \linkS4class{genind} object by
- population, returning a list of objects whose components each
- correspond to a population.\cr
+ The function \code{seppop} splits a \linkS4class{genind} or a
+ \linkS4class{genlight} object by population, returning a list of
+ objects whose components each correspond to a population.\cr
- By default, components of the list are \linkS4class{genind} objects.
- It can also be a matrix of genotypes corresponding to the x\$tab.\cr
+ For \linkS4class{genind} objects, the output can either be a list of
+ \linkS4class{genind} (default), or a list of matrices corresponding to
+ the \code{@tab} slot.
}
\usage{
\S4method{seppop}{genind}(x,pop=NULL,truenames=TRUE,res.type=c("genind","matrix"),
- drop=FALSE, treatOther=TRUE)
+ drop=FALSE, treatOther=TRUE, quiet=TRUE)
+
+\S4method{seppop}{genind}(x,pop=NULL, treatOther=TRUE, quiet=TRUE)
}
\arguments{
\item{x}{a \linkS4class{genind} object}
@@ -32,8 +36,12 @@
present in a subset of data should be discarded (TRUE) or kept anyway
(FALSE, default).}
\item{treatOther}{a logical stating whether elements of the
- \code{@other} slot should be treated as well (TRUE), or not
- (FALSE). See details in accessor documentations (\code{\link{pop}}).}
+ \code{@other} slot should be treated as well (TRUE), or not
+ (FALSE). See details in accessor documentations
+ (\code{\link{pop}}).}
+ \item{quiet}{a logical indicating whether warnings should be issued
+ when trying to subset components of the \code{@other} slot (TRUE),
+ or not (FALSE, default). }
}
\value{
According to 'res.type': a list of \linkS4class{genind} object
@@ -48,5 +56,17 @@
names(obj)
obj$Salers
+
+
+#### example for genlight objects ####
+x <- new("genlight", list(a=rep(1,1e3),b=rep(0,1e3),c=rep(1, 1e3)))
+x
+
+pop(x) # no population info
+pop(x) <- c("pop1","pop2", "pop1") # set population memberships
+pop(x)
+seppop(x)
+as.matrix(seppop(x)$pop1)[,1:20]
+as.matrix(seppop(x)$pop2)[,1:20,drop=FALSE]
}
\keyword{manip}
\ No newline at end of file
More information about the adegenet-commits
mailing list