[adegenet-commits] r982 - / pkg pkg/R pkg/man pkg/src
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Dec 21 20:01:48 CET 2011
Author: jombart
Date: 2011-12-21 20:01:48 +0100 (Wed, 21 Dec 2011)
New Revision: 982
Added:
misc/
pkg/NAMESPACE
Removed:
pkg/misc/
Modified:
pkg/ChangeLog
pkg/R/propShared.R
pkg/man/adegenet.package.Rd
pkg/man/propShared.Rd
pkg/src/sharedAll.c
Log:
new release
Modified: pkg/ChangeLog
===================================================================
--- pkg/ChangeLog 2011-12-19 13:38:33 UTC (rev 981)
+++ pkg/ChangeLog 2011-12-21 19:01:48 UTC (rev 982)
@@ -1,3 +1,16 @@
+ CHANGES IN ADEGENET VERSION 1.3-3
+
+BUG FIXES
+
+ o fixed a bug of propShared, which gave wrong results under weird
+ circumstances. The new implementation is entirely different, uses
+ C code, and is now applicable to data with any level of ploidy.
+
+ o tried making the package smaller by removing unnecessary files.
+
+
+
+
CHANGES IN ADEGENET VERSION 1.3-2
BUG FIXES
Added: pkg/NAMESPACE
===================================================================
--- pkg/NAMESPACE (rev 0)
+++ pkg/NAMESPACE 2011-12-21 19:01:48 UTC (rev 982)
@@ -0,0 +1,12 @@
+# Default NAMESPACE created by R
+# Remove the previous line if you edit this file
+
+# Export all names
+exportPattern(".")
+
+# Import all packages listed as Imports or Depends
+import(
+ methods,
+ MASS,
+ ade4
+)
Modified: pkg/R/propShared.R
===================================================================
--- pkg/R/propShared.R 2011-12-19 13:38:33 UTC (rev 981)
+++ pkg/R/propShared.R 2011-12-21 19:01:48 UTC (rev 982)
@@ -6,75 +6,114 @@
# Function propShared
######################
propShared <- function(obj){
- x <- obj
+ ## CHECK THAT THIS IS A VALID GENIND ##
+ if(!inherits(obj,"genind")) stop("obj must be a genind object.")
+ invisible(validObject(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))
+ ## GET MATRIX OF NB OF ALLELES ##
+ x <- round(obj at tab*ploidy(obj))
+ x[is.na(x)] <- 0L
- ## check ploidy level
- if(x$ploidy > 2) stop("not implemented for ploidy > 2")
- checkType(x)
+ ## COMPUTE NB OF SHARED ALLELES ##
+ n <- nInd(obj)
+ resVec <- integer(n*(n-1)/2)
+ res <- .C("nb_shared_all", as.integer(x), as.integer(resVec), as.integer(n), as.integer(ncol(obj$tab)), PACKAGE="adegenet")[[2]]
+ attr(res,"Size") <- n
+ attr(res,"Diag") <- FALSE
+ attr(res,"Upper") <- FALSE
+ class(res) <- "dist"
+ res <- as.matrix(res)
- ## 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)
+ ## COMPUTE NB OF ALLELES TYPED IN COMMON ##
+ tabNA <- propTyped(obj, by="both")
+ tabTypCom <- tabNA %*% t(tabNA) * ploidy(obj)
- ## 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)
- }
+
+ ## GET PROPORTIONS OF SHARED ALLELES ##
+ res <- res/tabTypCom
+ diag(res) <- 1L
+ colnames(res) <-rownames(res) <- indNames(obj)
+ 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)
-}
+## OLD, NON UNIFIED VERSION ##
+## 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)
## ######################
Modified: pkg/man/adegenet.package.Rd
===================================================================
--- pkg/man/adegenet.package.Rd 2011-12-19 13:38:33 UTC (rev 981)
+++ pkg/man/adegenet.package.Rd 2011-12-21 19:01:48 UTC (rev 982)
@@ -191,7 +191,7 @@
Package: \tab adegenet\cr
Type: \tab Package\cr
Version: \tab 1.3-3\cr
- Date: \tab 2011-11-11 \cr
+ Date: \tab 2011-12-21 \cr
License: \tab GPL (>=2)
}
}
Modified: pkg/man/propShared.Rd
===================================================================
--- pkg/man/propShared.Rd 2011-12-19 13:38:33 UTC (rev 981)
+++ pkg/man/propShared.Rd 2011-12-21 19:01:48 UTC (rev 982)
@@ -4,7 +4,7 @@
\title{Compute proportion of shared alleles}
\description{The function \code{propShared} computes the proportion of
shared alleles in a set of genotypes (i.e. from a \linkS4class{genind}
- object). Current implementation works for haploid and diploid genotypes.
+ object). Current implementation works for any level of ploidy.
}
\usage{
propShared(obj)
@@ -13,8 +13,7 @@
\item{obj}{a \linkS4class{genind} object.}
}
\details{
- Computations of the proportion of shared alleles are computed in C
- for diploid individuals, and in efficient R code for haploid genotypes.
+ Computations of the numbers of shared alleles are done in C.
Proportions are computed from all available data, i.e. proportion can
be computed as far as there is at least one typed locus in common
between two genotypes.
Modified: pkg/src/sharedAll.c
===================================================================
--- pkg/src/sharedAll.c 2011-12-19 13:38:33 UTC (rev 981)
+++ pkg/src/sharedAll.c 2011-12-21 19:01:48 UTC (rev 982)
@@ -19,6 +19,7 @@
#include "adesub.h"
+
void sharedAll(int *matAll, int *nRow, int *nCol, double *resVec)
{
/* Declare local C variables */
@@ -109,3 +110,46 @@
freeinttab(mat);
} /* end sharedAll */
+
+
+
+
+
+
+void nb_shared_all(int *in, int *out, int *nind, int *ncol){
+ int i, j, k, counter=0, **mat, n = *nind, p = *ncol;
+
+ /* allocate memory for table of allele nb */
+ tabintalloc(&mat, n, p);
+
+
+ /* reconstruct table of allele nb */
+ for(j=1;j<=p;j++){
+ for(i=1;i<=n;i++){
+ mat[i][j] = in[counter++];
+ }
+ }
+
+
+ /* perform computations */
+ int min_int(int a, int b){
+ if(a<b) return a;
+ return b;
+ }
+
+ counter = 0;
+ for(i=1;i<=(n-1);i++){
+ for(j=i+1;j<=n;j++){
+ out[counter] = 0; /* initialize result to zero */
+ for(k=1;k<=p;k++){
+ out[counter] = out[counter] + min_int(mat[i][k], mat[j][k]);
+ }
+ counter++;
+ }
+ }
+
+
+ /* Free allocated memory */
+ freeinttab(mat);
+
+} /* end nb_shared_all */
More information about the adegenet-commits
mailing list