[adegenet-commits] r134 - in pkg: . R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Jun 26 14:17:15 CEST 2008
Author: jombart
Date: 2008-06-26 14:17:15 +0200 (Thu, 26 Jun 2008)
New Revision: 134
Added:
pkg/R/basicMethods.R
pkg/R/genind2genpop.R
pkg/R/old2new.R
pkg/R/propTyped.R
pkg/man/propTyped.Rd
Modified:
pkg/DESCRIPTION
pkg/R/auxil.R
pkg/R/classes.R
pkg/R/propShared.R
pkg/man/genind.Rd
pkg/man/genpop.Rd
pkg/man/makefreq.Rd
Log:
Splitted up the code a bit. Added propTyped function and doc.
Implement further ploidy levels.
Modified: pkg/DESCRIPTION
===================================================================
--- pkg/DESCRIPTION 2008-06-25 17:22:38 UTC (rev 133)
+++ pkg/DESCRIPTION 2008-06-26 12:17:15 UTC (rev 134)
@@ -9,4 +9,4 @@
Description: Classes and functions for genetic data analysis within the multivariate framework.
License: GPL (>=2)
LazyLoad: yes
-Collate: classes.R auxil.R makefreq.R chooseCN.R dist.genpop.R export.R setAs.R gstat.randtest.R HWE.R import.R monmonier.R coords.monmonier.R spca.R spca.rtests.R zzz.R hybridize.R fstat.R propShared.R scale.R
\ No newline at end of file
+Collate: classes.R auxil.R genind2genpop.R propTyped.R basicMethods.R old2new.R makefreq.R chooseCN.R dist.genpop.R export.R setAs.R gstat.randtest.R HWE.R import.R monmonier.R coords.monmonier.R spca.R spca.rtests.R zzz.R hybridize.R fstat.R propShared.R scale.R
\ No newline at end of file
Modified: pkg/R/auxil.R
===================================================================
--- pkg/R/auxil.R 2008-06-25 17:22:38 UTC (rev 133)
+++ pkg/R/auxil.R 2008-06-26 12:17:15 UTC (rev 134)
@@ -453,3 +453,29 @@
} # end repool
+
+
+######################
+## miscellanous utils
+######################
+
+
+#######
+# nLoc
+#######
+setGeneric("nLoc", function(x,...){
+ standardGeneric("nLoc")
+})
+
+
+
+setMethod("nLoc","genind", function(x,...){
+ return(length(x at loc.names))
+})
+
+
+
+setMethod("nLoc","genpop", function(x,...){
+ return(length(x at loc.names))
+})
+
Added: pkg/R/basicMethods.R
===================================================================
--- pkg/R/basicMethods.R (rev 0)
+++ pkg/R/basicMethods.R 2008-06-26 12:17:15 UTC (rev 134)
@@ -0,0 +1,224 @@
+##########################
+# Method show for genind
+##########################
+setMethod ("show", "genind", function(object){
+ x <- object
+ cat("\n")
+ cat(" #####################\n")
+ cat(" ### Genind object ### \n")
+ cat(" #####################")
+ cat("\n- genotypes of individuals - \n")
+ cat("\nS4 class: ", as.character(class(x)))
+
+ cat("\n at call: ")
+ print(x at call)
+
+ p <- ncol(x at tab)
+ len <- 7
+
+ cat("\n at tab: ", nrow(x at tab), "x", ncol(x at tab), "matrix of genotypes\n" )
+
+ cat("\n at ind.names: vector of ", length(x at ind.names), "individual names")
+ cat("\n at loc.names: vector of ", length(x at loc.names), "locus names")
+ cat("\n at loc.nall: number of alleles per locus")
+ cat("\n at loc.fac: locus factor for the ", ncol(x at tab), "columns of @tab")
+ cat("\n at all.names: list of ", length(x at all.names), "components yielding allele names for each locus")
+ cat("\n at ploidy: ",x at ploidy)
+
+ cat("\n\nOptionnal contents: ")
+ cat("\n at pop: ", ifelse(is.null(x at pop), "- empty -", "factor giving the population of each individual"))
+ cat("\n at pop.names: ", ifelse(is.null(x at pop.names), "- empty -", "factor giving the population of each individual"))
+
+ cat("\n\n at other: ")
+ if(!is.null(x at other)){
+ cat("a list containing: ")
+ cat(ifelse(is.null(names(x at other)), "elements without names", paste(names(x at other), collapse= " ")), "\n")
+ } else {
+ cat("- empty -\n")
+ }
+
+ cat("\n")
+}
+) # end show method for genind
+
+
+
+
+##########################
+# Method show for genpop
+##########################
+setMethod ("show", "genpop", function(object){
+ x <- object
+ cat("\n")
+ cat(" #####################\n")
+ cat(" ### Genpop object ### \n")
+ cat(" #####################")
+ cat("\n- Alleles counts for populations - \n")
+ cat("\nS4 class: ", as.character(class(x)))
+
+ cat("\n at call: ")
+ print(x at call)
+
+ p <- ncol(x at tab)
+
+ cat("\n at tab: ", nrow(x at tab), "x", ncol(x at tab), "matrix of alleles counts\n" )
+
+ cat("\n at pop.names: vector of ", length(x at pop.names), "population names")
+ cat("\n at loc.names: vector of ", length(x at loc.names), "locus names")
+ cat("\n at loc.nall: number of alleles per locus")
+ cat("\n at loc.fac: locus factor for the ", ncol(x at tab), "columns of @tab")
+ cat("\n at all.names: list of ", length(x at all.names), "components yielding allele names for each locus")
+
+ cat("\n\n at other: ")
+ if(!is.null(x at other)){
+ cat("a list containing: ")
+ cat(ifelse(is.null(names(x at other)), "elements without names", paste(names(x at other), collapse= " ")), "\n")
+ } else {
+ cat("- empty -\n")
+ }
+
+ cat("\n")
+
+}
+) # end show method for genpop
+
+
+
+
+
+############################
+# Method summary for genind
+############################
+setMethod ("summary", "genind", function(object, ...){
+ x <- object
+ if(!inherits(x,"genind")) stop("To be used with a genind object")
+ if(is.null(x at pop)){
+ x at pop <- factor(rep(1,nrow(x at tab)))
+ x at pop.names <- ""
+ names(x at pop.names) <- "P1"
+ }
+
+ res <- list()
+
+ res$N <- nrow(x at tab)
+
+ res$pop.eff <- as.numeric(table(x at pop))
+ names(res$pop.eff) <- names(x at pop.names)
+
+ res$loc.nall <- x at loc.nall
+
+ temp <- genind2genpop(x,quiet=TRUE)@tab
+
+ res$pop.nall <- apply(temp,1,function(r) sum(r!=0,na.rm=TRUE))
+
+ res$NA.perc <- 100*sum(is.na(x at tab))/prod(dim(x at tab))
+
+ ## handle heterozygosity
+ if(x at ploidy > 1){
+ ## auxiliary function to compute observed heterozygosity
+ temp <- seploc(x,truenames=FALSE,res.type="matrix")
+ f1 <- function(tab){
+ H <- apply(tab, 1, function(vec) any(vec > 0 & vec < 1))
+ H <- mean(H,na.rm=TRUE)
+ return(H)
+ }
+
+ res$Hobs <- unlist(lapply(temp,f1))
+
+ ## auxiliary function to compute expected heterozygosity
+ ## freq is a vector of frequencies
+ f2 <- function(freq){
+ H <- 1-sum(freq*freq,na.rm=TRUE)
+ return(H)
+ }
+
+ temp <- genind2genpop(x,pop=rep(1,nrow(x at tab)),quiet=TRUE)
+ temp <- makefreq(temp,quiet=TRUE)$tab
+ temp.names <- colnames(temp)
+ temp <- as.vector(temp)
+ names(temp) <- temp.names
+ temp <- split(temp,x at loc.fac)
+ ## temp is a list of alleles frequencies (one element per locus)
+
+ res$Hexp <- unlist(lapply(temp,f2))
+ } else { # no possible heterozygosity for haploid genotypes
+ res$Hobs <- 0
+ res$Xexp <- 0
+ }
+
+ ## print to screen
+ listlab <- c("# Total number of genotypes: ",
+ "# Population sample sizes: ",
+ "# Number of alleles per locus: ",
+ "# Number of alleles per population: ",
+ "# Percentage of missing data: ",
+ "# Observed heterozygosity: ",
+ "# Expected heterozygosity: ")
+ cat("\n",listlab[1],res[[1]],"\n")
+ for(i in 2:7){
+ cat("\n",listlab[i],"\n")
+ print(res[[i]])
+ }
+
+ return(invisible(res))
+}) # end summary.genind
+
+
+
+
+
+############################
+# Method summary for genpop
+############################
+setMethod ("summary", "genpop", function(object, ...){
+ x <- object
+ if(!inherits(x,"genpop")) stop("To be used with a genpop object")
+
+ res <- list()
+
+ res$npop <- nrow(x at tab)
+
+ res$loc.nall <- x at loc.nall
+
+ res$pop.nall <- apply(x at tab,1,function(r) sum(r>0,na.rm=TRUE))
+
+ res$NA.perc <- 100*sum(is.na(x at tab))/prod(dim(x at tab))
+
+ # print to screen
+ listlab <- c("# Number of populations: ",
+ "# Number of alleles per locus: ",
+ "# Number of alleles per population: ",
+ "# Percentage of missing data: ")
+ cat("\n",listlab[1],res[[1]],"\n")
+ for(i in 2:4){
+ cat("\n",listlab[i],"\n")
+ print(res[[i]])
+ }
+
+ return(invisible(res))
+
+}
+)# end summary.genpop
+
+
+
+#} # end .initAdegenetClasses()
+
+
+
+
+
+
+###############
+# Methods "is"
+###############
+is.genind <- function(x){
+ res <- ( is(x, "genind") & validObject(x))
+ return(res)
+}
+
+is.genpop <- function(x){
+ res <- ( is(x, "genpop") & validObject(x))
+ return(res)
+}
+
Modified: pkg/R/classes.R
===================================================================
--- pkg/R/classes.R 2008-06-25 17:22:38 UTC (rev 133)
+++ pkg/R/classes.R 2008-06-26 12:17:15 UTC (rev 134)
@@ -439,387 +439,3 @@
######################
as.genpop <- genpop
-
-
-
-##########################
-# Method show for genind
-##########################
-setMethod ("show", "genind", function(object){
- x <- object
- cat("\n")
- cat(" #####################\n")
- cat(" ### Genind object ### \n")
- cat(" #####################")
- cat("\n- genotypes of individuals - \n")
- cat("\nS4 class: ", as.character(class(x)))
-
- cat("\n at call: ")
- print(x at call)
-
- p <- ncol(x at tab)
- len <- 7
-
- cat("\n at tab: ", nrow(x at tab), "x", ncol(x at tab), "matrix of genotypes\n" )
-
- cat("\n at ind.names: vector of ", length(x at ind.names), "individual names")
- cat("\n at loc.names: vector of ", length(x at loc.names), "locus names")
- cat("\n at loc.nall: number of alleles per locus")
- cat("\n at loc.fac: locus factor for the ", ncol(x at tab), "columns of @tab")
- cat("\n at all.names: list of ", length(x at all.names), "components yielding allele names for each locus")
- cat("\n at ploidy: ",x at ploidy)
-
- cat("\n\nOptionnal contents: ")
- cat("\n at pop: ", ifelse(is.null(x at pop), "- empty -", "factor giving the population of each individual"))
- cat("\n at pop.names: ", ifelse(is.null(x at pop.names), "- empty -", "factor giving the population of each individual"))
-
- cat("\n\n at other: ")
- if(!is.null(x at other)){
- cat("a list containing: ")
- cat(ifelse(is.null(names(x at other)), "elements without names", paste(names(x at other), collapse= " ")), "\n")
- } else {
- cat("- empty -\n")
- }
-
- cat("\n")
-}
-) # end show method for genind
-
-
-
-
-##########################
-# Method show for genpop
-##########################
-setMethod ("show", "genpop", function(object){
- x <- object
- cat("\n")
- cat(" #####################\n")
- cat(" ### Genpop object ### \n")
- cat(" #####################")
- cat("\n- Alleles counts for populations - \n")
- cat("\nS4 class: ", as.character(class(x)))
-
- cat("\n at call: ")
- print(x at call)
-
- p <- ncol(x at tab)
-
- cat("\n at tab: ", nrow(x at tab), "x", ncol(x at tab), "matrix of alleles counts\n" )
-
- cat("\n at pop.names: vector of ", length(x at pop.names), "population names")
- cat("\n at loc.names: vector of ", length(x at loc.names), "locus names")
- cat("\n at loc.nall: number of alleles per locus")
- cat("\n at loc.fac: locus factor for the ", ncol(x at tab), "columns of @tab")
- cat("\n at all.names: list of ", length(x at all.names), "components yielding allele names for each locus")
-
- cat("\n\n at other: ")
- if(!is.null(x at other)){
- cat("a list containing: ")
- cat(ifelse(is.null(names(x at other)), "elements without names", paste(names(x at other), collapse= " ")), "\n")
- } else {
- cat("- empty -\n")
- }
-
- cat("\n")
-
-}
-) # end show method for genpop
-
-
-
-
-
-############################
-# Method summary for genind
-############################
-setMethod ("summary", "genind", function(object, ...){
- x <- object
- if(!inherits(x,"genind")) stop("To be used with a genind object")
- if(is.null(x at pop)){
- x at pop <- factor(rep(1,nrow(x at tab)))
- x at pop.names <- ""
- names(x at pop.names) <- "P1"
- }
-
- res <- list()
-
- res$N <- nrow(x at tab)
-
- res$pop.eff <- as.numeric(table(x at pop))
- names(res$pop.eff) <- names(x at pop.names)
-
- res$loc.nall <- x at loc.nall
-
- temp <- genind2genpop(x,quiet=TRUE)@tab
-
- res$pop.nall <- apply(temp,1,function(r) sum(r!=0,na.rm=TRUE))
-
- res$NA.perc <- 100*sum(is.na(x at tab))/prod(dim(x at tab))
-
- # auxiliary function to compute observed heterozygosity
- temp <- seploc(x,truenames=FALSE,res.type="matrix")
- f1 <- function(tab){
- H <- sum(tab==0.5,na.rm=TRUE)/(2*nrow(tab))
- return(H)
- }
-
- res$Hobs <- unlist(lapply(temp,f1))
-
- # auxiliary function to compute expected heterozygosity
- # freq is a vector of frequencies
- f2 <- function(freq){
- H <- 1-sum(freq*freq,na.rm=TRUE)
- return(H)
- }
-
- temp <- genind2genpop(x,pop=rep(1,nrow(x at tab)),quiet=TRUE)
- temp <- makefreq(temp,quiet=TRUE)$tab
- temp.names <- colnames(temp)
- temp <- as.vector(temp)
- names(temp) <- temp.names
- temp <- split(temp,x at loc.fac)
- # temp is a list of alleles frequencies (one element per locus)
-
- res$Hexp <- unlist(lapply(temp,f2))
-
- # print to screen
- listlab <- c("# Total number of genotypes: ",
- "# Population sample sizes: ",
- "# Number of alleles per locus: ",
- "# Number of alleles per population: ",
- "# Percentage of missing data: ",
- "# Observed heterozygosity: ",
- "# Expected heterozygosity: ")
- cat("\n",listlab[1],res[[1]],"\n")
- for(i in 2:7){
- cat("\n",listlab[i],"\n")
- print(res[[i]])
- }
-
- return(invisible(res))
-}) # end summary.genind
-
-
-
-
-
-############################
-# Method summary for genpop
-############################
-setMethod ("summary", "genpop", function(object, ...){
- x <- object
- if(!inherits(x,"genpop")) stop("To be used with a genpop object")
-
- res <- list()
-
- res$npop <- nrow(x at tab)
-
- res$loc.nall <- x at loc.nall
-
- res$pop.nall <- apply(x at tab,1,function(r) sum(r>0,na.rm=TRUE))
-
- res$NA.perc <- 100*sum(is.na(x at tab))/prod(dim(x at tab))
-
- # print to screen
- listlab <- c("# Number of populations: ",
- "# Number of alleles per locus: ",
- "# Number of alleles per population: ",
- "# Percentage of missing data: ")
- cat("\n",listlab[1],res[[1]],"\n")
- for(i in 2:4){
- cat("\n",listlab[i],"\n")
- print(res[[i]])
- }
-
- return(invisible(res))
-
-}
-)# end summary.genpop
-
-
-
-#} # end .initAdegenetClasses()
-
-
-
-
-
-
-###############
-# Methods "is"
-###############
-is.genind <- function(x){
- res <- ( is(x, "genind") & validObject(x))
- return(res)
-}
-
-is.genpop <- function(x){
- res <- ( is(x, "genpop") & validObject(x))
- return(res)
-}
-
-
-
-
-
-
-###############################################################
-###############################################################
-# OTHER FUNCTIONS
-###############################################################
-###############################################################
-
-#########################
-# Function genind2genpop
-#########################
-genind2genpop <- function(x,pop=NULL,missing=c("NA","0","chi2"),quiet=FALSE){
-
- if(!is.genind(x)) stop("x is not a valid genind object")
-
- if(is.null(x at pop) && is.null(pop)) stop("pop is not provided either in x or in pop")
-
- missing <- match.arg(missing)
-
- if(!quiet) cat("\n Converting data from a genind to a genpop object... \n")
-
- # choose pop argument over x at pop
- if(!is.null(pop)) {
- if(length(pop) != nrow(x at tab)) stop("inconsistent length for factor pop")
- # keep levels in order of appearance
- pop <- as.character(pop)
- pop <- factor(pop, levels=unique(pop))
- } else {
- pop <- x at pop
- # keep levels in order of appearance
- pop <- as.character(pop)
- pop <- factor(pop, levels=unique(pop))
- if(!is.null(x at pop.names)) levels(pop) <- x at pop.names # restore real names
- }
-
- # make generic pop labels, store real pop names
- # pop.names <- levels(pop) ## no longer used
-
- # tabcount is a matrix pop x alleles, counting alleles per pop
- # *ploidy to have alleles counts
- f1 <- function(v){
- if(all(is.na(v))) return(NA) else return(sum(v,na.rm=TRUE))
- }
-
- f2 <- function(v){
- if(all(is.na(v)) || sum(v,na.rm=TRUE)==0) return(NA)
- return(v/(sum(v,na.rm=TRUE)))
- }
-
- tabcount <- x at ploidy * apply(x at tab,2,function(c) tapply(c,pop,f1))
- tabcount <- round(tabcount,digits=0)
- # restitute matrix class when only one pop
- if(is.null(dim(tabcount))) {
- lab.col <- names(tabcount)
- tabcount <- matrix(tabcount,nrow=1)
- colnames(tabcount) <- lab.col
- }
-## #meancol <- apply(tabcount,2,function(c) mean(c,na.rm=TRUE)) ## no longer used
-
-## # NA treatment
-## # Treatment when missing='REPLACE':
-## # if allele 'j' of locus 'k' in pop 'i' is missing, replace the NA by a number 'x' so that
-## # the frequency 'x/s' ('s' being the number of observations in 'k' ) equals the frequency 'f'
-## # computed on the whole data (i.e. considering all pop as one)
-## # Then x must verify:
-## # x/s = f(1-f) => x=f(1-f)s
-## #
-## # - eff.pop is a pop x locus matrix giving the corresponding sum of observations (i.e., 's')
-## # - temp is the same table but duplicated for all alleles
-## # - odd.vec is the vector of 'f(1-f)'
-## # - count.replace is a pop x alleles table yielding appropriate replacement numbers (i.e., 'x')
-
-## if(!is.na(missing) && any(is.na(tabcount))){
-## if(missing==0) tabcount[is.na(tabcount)] <- 0
-## if(toupper(missing)=="REPLACE") {
-## eff.pop <- t(apply(tabcount,1,function(r) tapply(r,x at loc.fac,sum,na.rm=TRUE)))
-## temp <- t(apply(eff.pop,1,function(r) rep(r,table(x at loc.fac))))
-
-## freq.allpop <- apply(tabcount,2,sum,na.rm=TRUE)
-## freq.allpop <- unlist(tapply(freq.allpop,x at loc.fac,f2))
-## odd.vec <- freq.allpop/(1-freq.allpop)
-
-## count.replace <- t(apply(temp,1,function(r) r*odd.vec))
-
-## tabcount[is.na(tabcount)] <- count.replace[is.na(tabcount)]
-## }
-## } # end of NA treatment
-
-
- ## make final object
- temp <- paste(rep(x at loc.names,x at loc.nall),unlist(x at all.names),sep=".")
- colnames(tabcount) <- temp
-
- prevcall <- match.call()
-
- res <- genpop(tab=tabcount, prevcall=prevcall)
- res at other <- x at other
-
- if(missing != "NA"){
- res <- na.replace(res, method=missing, quiet=quiet)
- }
-
- if(!quiet) cat("\n...done.\n\n")
-
- return(res)
-
-} # end genind2genpop
-
-
-
-
-
-##################
-# Methods old2new
-##################
-setGeneric("old2new", function(object) standardGeneric("old2new"))
-
-setMethod("old2new", "genind", function(object){
- x <- object
- res <- new("genind")
- theoLength <- 7
-
- res at tab <- as.matrix(x$tab)
- res at ind.names <- as.character(x$ind.names)
- res at loc.names <- as.character(x$loc.names)
- res at loc.nall <- as.integer(x$loc.nall)
- res at loc.fac <- as.factor(x$loc.fac)
- res at all.names <- as.list(x$all.names)
- if(!is.null(x$pop)) {
- res at pop <- as.factor(x$pop)
- theoLength <- theoLength + 1
- }
- if(!is.null(x$pop.names)) {
- res at pop.names <- as.character(x$pop.names)
- theoLength <- theoLength + 1
- }
- res at call <- match.call()
-
- if(length(object) > theoLength) warning("optional content else than pop and pop.names was not converted")
-
- return(res)
-})
-
-
-setMethod("old2new", "genpop", function(object){
- x <- object
- res <- new("genpop")
-
- res at tab <- as.matrix(x$tab)
- res at pop.names <- as.character(x$pop.names)
- res at loc.names <- as.character(x$loc.names)
- res at loc.nall <- as.integer(x$loc.nall)
- res at loc.fac <- as.factor(x$loc.fac)
- res at all.names <- as.list(x$all.names)
- res at call <- match.call()
-
- if(length(object)>7) warning("optional content was not converted")
-
- return(res)
-})
-
Added: pkg/R/genind2genpop.R
===================================================================
--- pkg/R/genind2genpop.R (rev 0)
+++ pkg/R/genind2genpop.R 2008-06-26 12:17:15 UTC (rev 134)
@@ -0,0 +1,99 @@
+#########################
+# Function genind2genpop
+#########################
+genind2genpop <- function(x,pop=NULL,missing=c("NA","0","chi2"),quiet=FALSE){
+
+ if(!is.genind(x)) stop("x is not a valid genind object")
+
+ if(is.null(x at pop) && is.null(pop)) stop("pop is not provided either in x or in pop")
+
+ missing <- match.arg(missing)
+
+ if(!quiet) cat("\n Converting data from a genind to a genpop object... \n")
+
+ # choose pop argument over x at pop
+ if(!is.null(pop)) {
+ if(length(pop) != nrow(x at tab)) stop("inconsistent length for factor pop")
+ # keep levels in order of appearance
+ pop <- as.character(pop)
+ pop <- factor(pop, levels=unique(pop))
+ } else {
+ pop <- x at pop
+ # keep levels in order of appearance
+ pop <- as.character(pop)
+ pop <- factor(pop, levels=unique(pop))
+ if(!is.null(x at pop.names)) levels(pop) <- x at pop.names # restore real names
+ }
+
+ # make generic pop labels, store real pop names
+ # pop.names <- levels(pop) ## no longer used
+
+ # tabcount is a matrix pop x alleles, counting alleles per pop
+ # *ploidy to have alleles counts
+ f1 <- function(v){
+ if(all(is.na(v))) return(NA) else return(sum(v,na.rm=TRUE))
+ }
+
+ f2 <- function(v){
+ if(all(is.na(v)) || sum(v,na.rm=TRUE)==0) return(NA)
+ return(v/(sum(v,na.rm=TRUE)))
+ }
+
+ tabcount <- x at ploidy * apply(x at tab,2,function(c) tapply(c,pop,f1))
+ tabcount <- round(tabcount,digits=0)
+ # restitute matrix class when only one pop
+ if(is.null(dim(tabcount))) {
+ lab.col <- names(tabcount)
+ tabcount <- matrix(tabcount,nrow=1)
+ colnames(tabcount) <- lab.col
+ }
+## #meancol <- apply(tabcount,2,function(c) mean(c,na.rm=TRUE)) ## no longer used
+
+## # NA treatment
+## # Treatment when missing='REPLACE':
+## # if allele 'j' of locus 'k' in pop 'i' is missing, replace the NA by a number 'x' so that
+## # the frequency 'x/s' ('s' being the number of observations in 'k' ) equals the frequency 'f'
+## # computed on the whole data (i.e. considering all pop as one)
+## # Then x must verify:
+## # x/s = f(1-f) => x=f(1-f)s
+## #
+## # - eff.pop is a pop x locus matrix giving the corresponding sum of observations (i.e., 's')
+## # - temp is the same table but duplicated for all alleles
+## # - odd.vec is the vector of 'f(1-f)'
+## # - count.replace is a pop x alleles table yielding appropriate replacement numbers (i.e., 'x')
+
+## if(!is.na(missing) && any(is.na(tabcount))){
+## if(missing==0) tabcount[is.na(tabcount)] <- 0
+## if(toupper(missing)=="REPLACE") {
+## eff.pop <- t(apply(tabcount,1,function(r) tapply(r,x at loc.fac,sum,na.rm=TRUE)))
+## temp <- t(apply(eff.pop,1,function(r) rep(r,table(x at loc.fac))))
+
+## freq.allpop <- apply(tabcount,2,sum,na.rm=TRUE)
+## freq.allpop <- unlist(tapply(freq.allpop,x at loc.fac,f2))
+## odd.vec <- freq.allpop/(1-freq.allpop)
+
+## count.replace <- t(apply(temp,1,function(r) r*odd.vec))
+
+## tabcount[is.na(tabcount)] <- count.replace[is.na(tabcount)]
+## }
+## } # end of NA treatment
+
+
+ ## make final object
+ temp <- paste(rep(x at loc.names,x at loc.nall),unlist(x at all.names),sep=".")
+ colnames(tabcount) <- temp
+
+ prevcall <- match.call()
+
+ res <- genpop(tab=tabcount, prevcall=prevcall)
+ res at other <- x at other
+
+ if(missing != "NA"){
+ res <- na.replace(res, method=missing, quiet=quiet)
+ }
+
+ if(!quiet) cat("\n...done.\n\n")
+
+ return(res)
+
+} # end genind2genpop
Added: pkg/R/old2new.R
===================================================================
--- pkg/R/old2new.R (rev 0)
+++ pkg/R/old2new.R 2008-06-26 12:17:15 UTC (rev 134)
@@ -0,0 +1,48 @@
+##################
+# Methods old2new
+##################
+setGeneric("old2new", function(object) standardGeneric("old2new"))
+
+setMethod("old2new", "genind", function(object){
+ x <- object
+ res <- new("genind")
+ theoLength <- 7
+
+ res at tab <- as.matrix(x$tab)
+ res at ind.names <- as.character(x$ind.names)
+ res at loc.names <- as.character(x$loc.names)
+ res at loc.nall <- as.integer(x$loc.nall)
+ res at loc.fac <- as.factor(x$loc.fac)
+ res at all.names <- as.list(x$all.names)
+ if(!is.null(x$pop)) {
+ res at pop <- as.factor(x$pop)
+ theoLength <- theoLength + 1
+ }
+ if(!is.null(x$pop.names)) {
+ res at pop.names <- as.character(x$pop.names)
+ theoLength <- theoLength + 1
+ }
+ res at call <- match.call()
+
+ if(length(object) > theoLength) warning("optional content else than pop and pop.names was not converted")
+
+ return(res)
+})
+
+
+setMethod("old2new", "genpop", function(object){
+ x <- object
+ res <- new("genpop")
+
+ res at tab <- as.matrix(x$tab)
+ res at pop.names <- as.character(x$pop.names)
+ res at loc.names <- as.character(x$loc.names)
+ res at loc.nall <- as.integer(x$loc.nall)
+ res at loc.fac <- as.factor(x$loc.fac)
+ res at all.names <- as.list(x$all.names)
+ res at call <- match.call()
+
+ if(length(object)>7) warning("optional content was not converted")
+
+ return(res)
+})
Modified: pkg/R/propShared.R
===================================================================
--- pkg/R/propShared.R 2008-06-25 17:22:38 UTC (rev 133)
+++ pkg/R/propShared.R 2008-06-26 12:17:15 UTC (rev 134)
@@ -7,33 +7,59 @@
######################
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))
-
- ## 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]]
+ ## check ploidy level
+ if(x$ploidy > 2) stop("not implemented for ploidy > 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")
+ #### have to think how AFLP should be handled here.
+ #### maybe dist would do the job..
+ ## compute numbers of common alleles
+ ## X <- x at tab
+ ## X[is.na(X)] <- 0
+ ## M <- X %*% t(X)
+
+ ## ## compute numbers of alleles used in each comparison
+ ## nAllByInd <- propTyped(x,by="ind")*x at ploidy
+ ## idx <- expand.grid(1:nrow(x$tab), 1:nrow(x$tab))
+ ## temp <- cbind(nAllByInd[idx[,1]] , nAllByInd[idx[,2]])
+ ## N <- matrix(apply(temp, 1, min), ncol=nrow(x$tab))
+
+ }
+ ## 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
Added: pkg/R/propTyped.R
===================================================================
--- pkg/R/propTyped.R (rev 0)
+++ pkg/R/propTyped.R 2008-06-26 12:17:15 UTC (rev 134)
@@ -0,0 +1,79 @@
+############
+# propTyped
+############
+setGeneric("propTyped", function(x,...){
+ standardGeneric("propTyped")
+})
+
+
+
+setMethod("propTyped","genind", function(x, by=c("ind","loc","both")){
+
+ by <- match.arg(by)
+
+ ## auxil function f1
+ f1 <- function(vec){
+ if(any(is.na(vec))) return(0)
+ else return(1)
+ }
+
+ ## temp is a list (one component / marker)
+ ## with n values (0: not typed, 1: typed)
+ kX <- seploc(x,res.type="matrix")
+ temp <- lapply(kX, function(X) apply(X, 1, f1))
+
+ ## by individual
+ if(by=="ind"){
+ temp <- as.data.frame(temp)
+ res <- apply(temp,1,mean)
+ }
+
+ ## by locus
+ if(by=="loc"){
+ res <- unlist(lapply(temp,mean))
+ }
+
+ ## by individual and locus
+ if(by=="both"){
+ res <- as.matrix(as.data.frame(temp))
+ }
+
+ return(res)
+})
+
+
+
+
+setMethod("propTyped","genpop", function(x, by=c("pop","loc","both")){
+
+ by <- match.arg(by)
+
+ ## auxil function f1
+ f1 <- function(vec){
+ if(any(is.na(vec))) return(0)
+ else return(1)
+ }
+
+ ## temp is a list (one component / marker)
+ ## with n values (0: not typed, 1: typed)
+ kX <- seploc(x,res.type="matrix")
+ temp <- lapply(kX, function(X) apply(X, 1, f1))
+
+ ## by individual
+ if(by=="pop"){
+ temp <- as.data.frame(temp)
+ res <- apply(temp,1,mean)
+ }
+
+ ## by locus
+ if(by=="loc"){
+ res <- unlist(lapply(temp,mean))
+ }
+
+ ## by individual and locus
+ if(by=="both"){
+ res <- as.matrix(as.data.frame(temp))
+ }
+
+ return(res)
+})
Modified: pkg/man/genind.Rd
===================================================================
--- pkg/man/genind.Rd 2008-06-25 17:22:38 UTC (rev 133)
+++ pkg/man/genind.Rd 2008-06-26 12:17:15 UTC (rev 134)
@@ -5,6 +5,8 @@
\alias{show,genind-method}
\alias{names,genind-method}
\alias{summary,genind-method}
+\alias{nLoc}
+\alias{nLoc,genind-method}
\alias{.valid.genind}
\title{adegenet formal class (S4) for individual genotypes}
\description{The S4 class \code{genind} is used to store individual genotypes.\cr
@@ -51,10 +53,11 @@
object (same as print)}
\item{summary}{\code{signature(object = "genind")}: summarizes a
genind object, invisibly returning its content}
+ \item{nLoc}{\code{signature(object = "genind")}: returns the number
+ of loci of the object}
+
}
}
-
-\references{}
\seealso{\code{\link{as.genind}}, \code{\link{is.genind}}, \code{\link{genind2genpop}},
\code{\link{genpop}}, \code{\link{import2genind}},
\code{\link{read.genetix}}, \code{\link{read.genepop}},
Modified: pkg/man/genpop.Rd
===================================================================
--- pkg/man/genpop.Rd 2008-06-25 17:22:38 UTC (rev 133)
+++ pkg/man/genpop.Rd 2008-06-26 12:17:15 UTC (rev 134)
@@ -5,6 +5,7 @@
\alias{names,genpop-method}
\alias{show,genpop-method}
\alias{summary,genpop-method}
+\alias{nLoc,genpop-method}
\title{adegenet formal class (S4) for allele counts in populations}
\description{An object of class \code{genpop} contain alleles counts
for several loci.\cr
@@ -35,10 +36,15 @@
}
\section{Methods}{
\describe{
- \item{dist}{\code{signature(x = "genpop", method = "ANY", diag = "ANY", upper = "ANY", p = "missing")}: ... }
- \item{names}{\code{signature(x = "genpop")}: ... }
- \item{show}{\code{signature(object = "genpop")}: ... }
- \item{summary}{\code{signature(object = "genpop")}: ... }
+ \item{names}{\code{signature(x = "genpop")}: give the names of the
+ components of a genpop object}
+ \item{print}{\code{signature(x = "genpop")}: prints a genpop object}
+ \item{show}{\code{signature(object = "genpop")}: shows a genpop
+ object (same as print)}
+ \item{summary}{\code{signature(object = "genpop")}: summarizes a
+ genpop object, invisibly returning its content}
+ \item{nLoc}{\code{signature(object = "genpop")}: returns the number
+ of loci of the object}
}
}
\references{}
Modified: pkg/man/makefreq.Rd
===================================================================
--- pkg/man/makefreq.Rd 2008-06-25 17:22:38 UTC (rev 133)
+++ pkg/man/makefreq.Rd 2008-06-26 12:17:15 UTC (rev 134)
@@ -29,7 +29,6 @@
\item{nobs}{number of observations (i.e. alleles) for each population x locus combinaison.}
\item{call}{the matched call}
}
-\references{}
\seealso{\code{\link{genpop}}
}
\author{ Thibaut Jombart \email{jombart at biomserv.univ-lyon1.fr} }
Added: pkg/man/propTyped.Rd
===================================================================
--- pkg/man/propTyped.Rd (rev 0)
+++ pkg/man/propTyped.Rd 2008-06-26 12:17:15 UTC (rev 134)
@@ -0,0 +1,48 @@
+\name{propTyped-methods}
+\docType{methods}
+\alias{propTyped}
+\alias{propTyped-methods}
+\alias{propTyped,genind-method}
+\alias{propTyped,genpop-method}
+\title{ Compute the proportion of typed elements }
+\description{
+ The generic function \code{propTyped} is devoted to investigating the
+ structure of missing data in adegenet objects.\cr
+
+ Methods are defined for \linkS4class{genind} and \linkS4class{genpop}
+ objects. They can return the proportion of available
+ (i.e. non-missing) data per individual/population, locus, or the
+ combination of both in with case the matrix indicates which entity
+ (individual or population) was typed on which locus.
+}
+\usage{
+\S4method{propTyped}{genind}(x, by=c("ind","loc","both"))
+\S4method{propTyped}{genpop}(x, by=c("pop","loc","both"))
+}
+\arguments{
+ \item{x}{a \linkS4class{genind} and \linkS4class{genpop} object}
+ \item{by}{a character being "ind","loc", or "both" for
+ \linkS4class{genind} object and "pop","loc", or "both" for
+ \linkS4class{genpop} object. It specifies whether proportion of typed
+ data are provided by entity ("ind"/"pop"), by locus ("loc") or both
+ ("both"). See details.}
+ }
+ \value{
+ A vector of proportion (when \code{by} equals "ind", "pop", or
+ "loc"), or a matrix of binary data (when \code{by} equals "both")
+}
+\details{
+ The argument \code{method} is used as follows:\cr
+
+ - \code{sigma}: scaling is made using the usual standard deviation\cr
+
+ - \code{binom}: scaling is made using the theoretical variance of the
+ allele frequency. This can be used to avoid that frequencies close to
+ 0.5 have a stronger variance that those close to 0 or 1.
+}
+\author{Thibaut Jombart \email{jombart at biomserv.univ-lyon1.fr} }
+\examples{
+
+}
+\keyword{methods}
+\keyword{manip}
More information about the adegenet-commits
mailing list