[adegenet-commits] r452 - in www: . files files/patches
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Oct 14 15:06:40 CEST 2009
Author: jombart
Date: 2009-10-14 15:06:39 +0200 (Wed, 14 Oct 2009)
New Revision: 452
Added:
www/files/adegenet_1.2-3.tgz
www/files/patches/
www/files/patches/classes.R
www/files/patches/propShared.R
Modified:
www/download.html
Log:
Added patches to the download section.
Modified: www/download.html
===================================================================
--- www/download.html 2009-10-14 11:30:32 UTC (rev 451)
+++ www/download.html 2009-10-14 13:06:39 UTC (rev 452)
@@ -21,7 +21,7 @@
(adegenet_1.2-3)
is available as:<br>
- <a href="files/adegenet_1.2-3.tar.gz">linux/unix sources</a><br>
-- MacOS X binary<br>
+- <a href="files/adegenet_1.2-3.tgz">MacOS X binary</a><br>
- <a href="files/adegenet_1.2-3.zip">Windows binary</a><br>
<br>
<img alt="" src="images/bullet.png" style="width: 10px; height: 10px;">
@@ -44,6 +44,10 @@
(CRAN) ones. Simply download the file in your working directory and
type <span style="font-family: monospace;">source("[your-patch-file.R]")</span>
to use a patch.<br>
+- <a style="font-family: monospace;" href="files/patches/classes.R">classes.R</a>:
+removed the 'no dot' constraint in locus names<br>
+- <a style="font-family: monospace;" href="files/patches/propShared.R">propShared.R</a>:
+fixes a bug identified by Valeria Paccapelo occuring with NAs<br>
<br>
<img alt="" src="images/bullet.png" style="width: 10px; height: 10px;">
<span style="font-weight: bold;">Older
Added: www/files/adegenet_1.2-3.tgz
===================================================================
(Binary files differ)
Property changes on: www/files/adegenet_1.2-3.tgz
___________________________________________________________________
Name: svn:mime-type
+ application/octet-stream
Added: www/files/patches/classes.R
===================================================================
--- www/files/patches/classes.R (rev 0)
+++ www/files/patches/classes.R 2009-10-14 13:06:39 UTC (rev 452)
@@ -0,0 +1,457 @@
+########################################################################
+# adegenet classes definitions. All classes are S4.
+#
+# Thibaut Jombart, November 2007
+# t.jombart at imperial.ac.uk
+########################################################################
+
+###############################
+# Two classes of R object are
+# defined :
+# gen - common part to genind and genpop
+# genind - genotypes of individuals
+# genpop - allelic frequencies of populations
+###############################
+
+
+###############################################################
+###############################################################
+# AUXILIARY FUNCTIONS
+###############################################################
+###############################################################
+
+
+
+
+###############################################################
+###############################################################
+# CLASSES DEFINITION
+###############################################################
+###############################################################
+
+##.initAdegenetClasses <- function(){
+
+
+####################
+# Unions of classes
+####################
+setClassUnion("listOrNULL", c("list","NULL"))
+setClassUnion("factorOrNULL", c("factor","NULL"))
+setClassUnion("charOrNULL", c("character","NULL"))
+setClassUnion("callOrNULL", c("call","NULL"))
+setClassUnion("intOrNum", c("integer","numeric","NULL"))
+
+
+
+####################
+# virtual class gen
+####################
+.gen.valid <- function(object){
+ # this function tests only the consistency
+ # of the length of each component
+ p <- ncol(object at tab)
+ k <- length(unique(object at loc.names))
+
+
+ if(!is.null(object at loc.fac)){
+ if(length(object at loc.fac) != p) {
+ cat("\ninvalid length for loc.fac\n")
+ return(FALSE)
+ }
+
+ if(length(levels(object at loc.fac)) != k) {
+ cat("\ninvalid number of levels in loc.fac\n")
+ return(FALSE)
+ }
+ }
+
+ if(!is.null(object at loc.nall)){
+ if(length(object at loc.nall) != k) {
+ cat("\ninvalid length in loc.nall\n")
+ return(FALSE)
+ }
+ }
+
+ temp <- table(object at loc.names[object at loc.names!=""])
+ if(any(temp>1)) {
+ warning("\nduplicate names in loc.names:\n")
+ print(temp[temp>1])
+ }
+
+ if(!is.null(object at all.names)){
+ if(length(unlist(object at all.names)) != p) {
+ cat("\ninvalid length in all.names\n")
+ return(FALSE)
+ }
+ }
+
+ return(TRUE)
+
+}# end .gen.valid
+
+
+setClass("gen", representation(tab = "matrix",
+ loc.names = "character",
+ loc.fac = "factorOrNULL",
+ loc.nall = "intOrNum",
+ all.names = "listOrNULL",
+ call = "callOrNULL",
+ "VIRTUAL"),
+ prototype(tab=matrix(ncol=0,nrow=0), loc.nall=integer(0), call=NULL))
+
+setValidity("gen", .gen.valid)
+
+
+
+
+
+########################
+# virtual class indInfo
+########################
+setClass("indInfo", representation(ind.names = "character",
+ pop = "factorOrNULL",
+ pop.names = "charOrNULL",
+ ploidy = "integer",
+ type = "character",
+ other = "listOrNULL", "VIRTUAL"),
+ prototype(pop=NULL, pop.names = NULL, type = "codom", ploidy = as.integer(2), other = NULL))
+
+
+
+
+
+###############
+# Class genind
+###############
+.genind.valid <- function(object){
+ if(!.gen.valid(object)) return(FALSE)
+
+ if(length(object at ind.names) != nrow(object at tab)) {
+ cat("\ninvalid length in ind.names\n")
+ return(FALSE)
+ }
+
+ temp <- table(object at ind.names[object at ind.names!=""])
+ if(any(temp>1)) {
+ warning("\nduplicate names in ind.names:\n")
+ print(temp[temp>1])
+ }
+
+ if(!is.null(object at pop)){ # check pop
+
+ if(length(object at pop) != nrow(object at tab)) {
+ cat("\npop is given but has invalid length\n")
+ return(FALSE)
+ }
+
+ if(is.null(object at pop.names)) {
+ cat("\npop is provided without pop.names")
+ }
+
+
+ if(length(object at pop.names) != length(levels(object at pop))) {
+ cat("\npop.names has invalid length\n")
+ return(FALSE)
+ }
+
+ temp <- table(object at pop.names[object at pop.names!=""])
+ if(any(temp>1)) {
+ warning("\nduplicate names in pop.names:\n")
+ print(temp[temp>1])
+ }
+
+ } # end check pop
+
+ ## check ploidy
+ if(object at ploidy < as.integer(1)){
+ cat("\nploidy inferior to 1\n")
+ return(FALSE)
+ }
+
+ ## check type of marker
+ if(!object at type %in% c("codom","PA") ){
+ cat("\nunknown type of marker\n")
+ return(FALSE)
+ }
+
+
+ return(TRUE)
+} #end .genind.valid
+
+setClass("genind", contains=c("gen", "indInfo"))
+setValidity("genind", .genind.valid)
+
+
+
+########################
+# virtual class popInfo
+########################
+setClass("popInfo", representation(pop.names = "character", ploidy = "integer",
+ type = "character", other = "listOrNULL", "VIRTUAL"),
+ prototype(type = "codom", ploidy = as.integer(2), other = NULL))
+
+
+
+###############
+# Class genpop
+###############
+.genpop.valid <- function(object){
+ if(!.gen.valid(object)) return(FALSE)
+ if(length(object at pop.names) != nrow(object at tab)) {
+ cat("\ninvalid length in pop.names\n")
+ return(FALSE)
+ }
+
+ temp <- table(object at pop.names[object at pop.names!=""])
+ if(any(temp>1)) {
+ warning("\nduplicate names in pop.names:\n")
+ print(temp[temp>1])
+ }
+
+ ## check ploidy
+ if(object at ploidy < as.integer(1)){
+ cat("\nploidy inferior to 1\n")
+ return(FALSE)
+ }
+
+ ## check type of marker
+ if(!object at type %in% c("codom","PA") ){
+ cat("\nunknown type of marker\n")
+ return(FALSE)
+ }
+
+ return(TRUE)
+} #end .genpop.valid
+
+setClass("genpop", contains=c("gen", "popInfo"))
+setValidity("genpop", .genpop.valid)
+
+
+
+
+
+
+
+###############################################################
+###############################################################
+# MAIN CLASS METHODS
+###############################################################
+###############################################################
+
+
+
+#################
+# Function names
+#################
+setMethod("names", signature(x = "genind"), function(x){
+ return(slotNames(x))
+})
+
+setMethod("names", signature(x = "genpop"), function(x){
+ return(slotNames(x))
+})
+
+
+
+
+
+##################
+# Function genind
+##################
+## constructor of a genind object
+genind <- function(tab,pop=NULL,prevcall=NULL,ploidy=2,type=c("codom","PA")){
+ ## handle arguments
+ X <- as.matrix(tab)
+ if(is.null(colnames(X))) stop("tab columns have no name.")
+ if(is.null(rownames(X))) {rownames(X) <- 1:nrow(X)}
+
+ type <- match.arg(type)
+ ploidy <- as.integer(ploidy)
+ nind <- nrow(X)
+
+
+ ## HANDLE LABELS ##
+
+ ## loc names is not type-dependent
+ temp <- colnames(X)
+ ## temp <- gsub("[.].*$","",temp)
+ temp <- gsub("[.][^.]*$", "", temp)
+ temp <- .rmspaces(temp)
+ loc.names <- unique(temp)
+ nloc <- length(loc.names)
+ loc.codes <- .genlab("L",nloc)
+ names(loc.names) <- loc.codes
+
+ ## ind names is not type-dependent either
+ ind.codes <- .genlab("", nind)
+ ind.names <- .rmspaces(rownames(X))
+ names(ind.names) <- ind.codes
+ rownames(X) <- ind.codes
+
+
+ if(type=="codom"){
+ ## loc.nall
+ loc.nall <- table(temp)[match(loc.names,names(table(temp)))]
+ loc.nall <- as.integer(loc.nall)
+ names(loc.nall) <- loc.codes
+
+ ## loc.fac
+ loc.fac <- rep(loc.codes,loc.nall)
+
+ ## alleles name
+ temp <- colnames(X)
+ temp <- gsub("^.*[.]","",temp)
+ temp <- .rmspaces(temp)
+ all.names <- split(temp,loc.fac)
+ all.codes <- lapply(all.names,function(e) .genlab("",length(e)))
+ for(i in 1:length(all.names)){
+ names(all.names[[i]]) <- all.codes[[i]]
+ }
+
+ colnames(X) <- paste(loc.fac,unlist(all.codes),sep=".")
+ loc.fac <- as.factor(loc.fac)
+ } else { # end if type=="codom" <=> if type=="PA"
+ colnames(X) <- loc.codes
+ loc.fac <- NULL
+ all.names <- NULL
+ loc.nall <- NULL
+ }
+
+ ## Ideally I should use an 'initialize' method here
+ res <- new("genind")
+ res at tab <- X
+ res at ind.names <- ind.names
+ res at loc.names <- loc.names
+ res at loc.nall <- loc.nall
+ res at loc.fac <- loc.fac
+ res at all.names <- all.names
+
+ ## populations name (optional)
+ ## beware, keep levels of pop sorted in
+ ## there order of appearance
+ if(!is.null(pop)) {
+ # convert pop to a factor if it is not
+ if(!is.factor(pop)) {pop <- factor(pop)}
+ pop.lab <- .genlab("P",length(levels(pop)) )
+ # put pop levels in appearance order
+ pop <- as.character(pop)
+ pop <- factor(pop, levels=unique(pop))
+ temp <- pop
+ # now levels are correctly ordered
+ levels(pop) <- pop.lab
+ res at pop <- pop
+ pop.names <- as.character(levels(temp))
+ names(pop.names) <- as.character(levels(res at pop))
+ res at pop.names <- pop.names
+ }
+
+ ## ploidy
+ plo <- as.integer(ploidy)
+ if(plo < as.integer(1)) stop("ploidy inferior to 1")
+ res at ploidy <- plo
+
+ ## type of marker
+ res at type <- as.character(type)
+
+ if(is.null(prevcall)) {prevcall <- match.call()}
+ res at call <- prevcall
+
+ return(res)
+
+} # end genind
+
+######################
+# alias for as.genind
+######################
+as.genind <- genind
+
+
+
+##################
+# Function genpop
+##################
+genpop <- function(tab,prevcall=NULL,ploidy=as.integer(2),type=c("codom","PA")){
+
+ ## handle args
+ X <- as.matrix(tab)
+ if(is.null(colnames(X))) stop("tab columns have no name.")
+ if(is.null(rownames(X))) {rownames(X) <- 1:nrow(X)}
+
+ type <- match.arg(type)
+ ploidy <- as.integer(ploidy)
+ npop <- nrow(X)
+
+
+ ## HANDLE LABELS ##
+
+ ## loc names is not type-dependent
+ temp <- colnames(X)
+ ## temp <- gsub("[.].*$","",temp)
+ temp <- gsub("[.][^.]*$", "", temp)
+ temp <- .rmspaces(temp)
+ loc.names <- unique(temp)
+ nloc <- length(loc.names)
+ loc.codes <- .genlab("L",nloc)
+ names(loc.names) <- loc.codes
+
+ ## pop names is not type-dependent either
+ pop.codes <- .genlab("", npop)
+ pop.names <- .rmspaces(rownames(X))
+ names(pop.names) <- pop.codes
+ rownames(X) <- pop.codes
+
+ ## type-dependent stuff
+ if(type=="codom"){
+ ## loc.nall
+ loc.nall <- table(temp)[match(loc.names,names(table(temp)))]
+ loc.nall <- as.integer(loc.nall)
+ names(loc.nall) <- loc.codes
+
+ ## loc.fac
+ loc.fac <- rep(loc.codes,loc.nall)
+
+ ## alleles name
+ temp <- colnames(X)
+ temp <- gsub("^.*[.]","",temp)
+ temp <- .rmspaces(temp)
+ all.names <- split(temp,loc.fac)
+ all.codes <- lapply(all.names,function(e) .genlab("",length(e)))
+ for(i in 1:length(all.names)){
+ names(all.names[[i]]) <- all.codes[[i]]
+ }
+
+ rownames(X) <- pop.codes
+ colnames(X) <- paste(loc.fac,unlist(all.codes),sep=".")
+ loc.fac <- as.factor(loc.fac)
+ } else { # end if type=="codom" <=> if type=="PA"
+ colnames(X) <- loc.codes
+ loc.fac <- NULL
+ all.names <- NULL
+ loc.nall <- NULL
+ }
+
+ res <- new("genpop")
+
+ res at tab <- X
+ res at pop.names <- pop.names
+ res at loc.names <- loc.names
+ res at loc.nall <- loc.nall
+ res at loc.fac <- loc.fac
+ res at all.names <- all.names
+ res at ploidy <- ploidy
+ res at type <- as.character(type)
+
+ if(is.null(prevcall)) {prevcall <- match.call()}
+ res at call <- prevcall
+
+ return(res)
+
+} # end genpop
+
+
+
+######################
+# alias for as.genpop
+######################
+as.genpop <- genpop
+
Added: www/files/patches/propShared.R
===================================================================
--- www/files/patches/propShared.R (rev 0)
+++ www/files/patches/propShared.R 2009-10-14 13:06:39 UTC (rev 452)
@@ -0,0 +1,127 @@
+## propShared computes the proportion of shared alleles
+## in a genind object
+
+
+######################
+# Function propShared
+######################
+propShared <- function(obj){
+ x <- obj
+
+ ## convert alleles to integers (alleles may be characters)
+ x at all.names <- lapply(x at all.names, function(v) 1:length(v))
+
+ ## check that this is a valid genind
+ if(!inherits(x,"genind")) stop("obj must be a genind object.")
+ invisible(validObject(x))
+
+ ## check ploidy level
+ if(x$ploidy > 2) stop("not implemented for ploidy > 2")
+ checkType(x)
+
+
+ ## if ploidy = 1
+ if(x$ploidy == as.integer(1)){
+ ## stop("not implemented for ploidy = 1")
+ ## compute numbers of alleles used in each comparison
+ nAllByInd <- propTyped(x,"both")
+ nAll <- nAllByInd %*% t(nAllByInd)
+
+ ## compute numbers of common alleles
+ X <- x at tab
+ X[is.na(X)] <- 0
+ M <- X %*% t(X)
+
+ ## result
+ res <- M / nAll
+ res[is.nan(res)] <- NA # as 0/0 is NaN (when no common locus typed)
+ colnames(res) <- rownames(res) <- x$ind.names
+ return(res)
+ }
+
+ ## if ploidy = 2
+ if(x$ploidy == as.integer(2)){
+ ## build a matrix of genotypes (in rows) coded by integers
+ ## NAs are coded by 0
+ ## The matrix is a cbind of two matrices, storing respectively the
+ ## first and the second allele.
+ temp <- genind2df(x,usepop=FALSE)
+ alleleSize <- max(apply(temp,1:2,nchar))/2
+ mat1 <- apply(temp, 1:2, substr, 1, alleleSize)
+ mat2 <- apply(temp, 1:2, substr, alleleSize+1, alleleSize*2)
+
+ matAll <- cbind(mat1,mat2)
+ matAll <- apply(matAll,1:2,as.integer)
+ matAll[is.na(matAll)] <- 0
+
+ n <- nrow(matAll)
+ resVec <- double(n*(n-1)/2)
+ res <- .C("sharedAll", as.integer(as.matrix(matAll)),
+ n, ncol(matAll), resVec, PACKAGE="adegenet")[[4]]
+
+ attr(res,"Size") <- n
+ attr(res,"Diag") <- FALSE
+ attr(res,"Upper") <- FALSE
+ class(res) <- "dist"
+ res <- as.matrix(res)
+ } # end if ploidy = 2
+
+ diag(res) <- 1
+ rownames(res) <- x at ind.names
+ colnames(res) <- x at ind.names
+ return(res)
+}
+
+
+
+
+## ######################
+## # Function propShared (old, pure-R version)
+## ######################
+## propShared <- function(obj){
+
+## x <- obj
+## ## check that this is a valid genind
+## if(!inherits(x,"genind")) stop("obj must be a genind object.")
+## invisible(validObject(x))
+
+## ## replace NAs
+## x <- na.replace(x, method="0")
+
+## ## some useful variables
+## nloc <- length(x at loc.names)
+
+## ## fnorm: auxiliary function for scaling
+## fnorm <- function(vec){
+## norm <- sqrt(sum(vec*vec))
+## if(length(norm) > 0 && norm > 0) {return(vec/norm)}
+## return(vec)
+## }
+
+## ## auxiliary function f1
+## ## computes the proportion of shared alleles in one locus
+## f1 <- function(X){
+## X <- t(apply(X, 1, fnorm))
+## res <- X %*% t(X)
+## res[res>0.51 & res<0.9] <- 0.5 # remap case one heteroZ shares the allele of on homoZ
+## return(res)
+## }
+
+## ## separate data per locus
+## temp <- seploc(x)
+## listProp <- lapply(temp, function(e) f1(e at tab))
+
+## ## produce the final result
+## res <- listProp[[1]]
+## if(nloc>2){
+## for(i in 2:nloc){
+## res <- res + listProp[[i]]
+## }
+## }
+
+## res <- res/nloc
+## rownames(res) <- x at ind.names
+## colnames(res) <- x at ind.names
+
+## return(res)
+## }
More information about the adegenet-commits
mailing list