[adegenet-commits] r236 - pkg/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sun Jan 25 16:38:16 CET 2009
Author: jombart
Date: 2009-01-25 16:38:16 +0100 (Sun, 25 Jan 2009)
New Revision: 236
Modified:
pkg/R/auxil.R
pkg/R/classes.R
Log:
Implmenting 'type'
Modified: pkg/R/auxil.R
===================================================================
--- pkg/R/auxil.R 2009-01-25 15:19:50 UTC (rev 235)
+++ pkg/R/auxil.R 2009-01-25 15:38:16 UTC (rev 236)
@@ -87,7 +87,7 @@
# checkType
############
checkType <- function(markType){
- if(markType=="codom") return()
+ if(markType=="codom") return() # always ok for codominant markers
currCall <- match.call()
currFunction <- sub("[[:space:]]*[(].*","",currCall)
@@ -98,6 +98,6 @@
if(! currFunction %in% dominOk){
msgError <- paste(currFunction,"is not implemented for dominant markers")
stop(msgError)
- }
+ } else return() # else, ok.
} # end checkType
Modified: pkg/R/classes.R
===================================================================
--- pkg/R/classes.R 2009-01-25 15:19:50 UTC (rev 235)
+++ pkg/R/classes.R 2009-01-25 15:38:16 UTC (rev 236)
@@ -22,36 +22,36 @@
-#######################
-# Function rmspaces
-#######################
-# removes spaces and tab at the begining and the end of each element of charvec
-.rmspaces <- function(charvec){
- charvec <- gsub("^([[:blank:]]*)([[:space:]]*)","",charvec)
- charvec <- gsub("([[:blank:]]*)([[:space:]]*)$","",charvec)
- return(charvec)
-}
+## #######################
+## # Function rmspaces
+## #######################
+## # removes spaces and tab at the begining and the end of each element of charvec
+## .rmspaces <- function(charvec){
+## charvec <- gsub("^([[:blank:]]*)([[:space:]]*)","",charvec)
+## charvec <- gsub("([[:blank:]]*)([[:space:]]*)$","",charvec)
+## return(charvec)
+## }
-###################
-# Function .genlab
-###################
-# recursive function to have labels of constant length
-# base = a character string
-# n = number of labels
-.genlab <- function(base, n) {
- f1 <- function(cha,n){
- if(nchar(cha)<n){
- cha <- paste("0",cha,sep="")
- return(f1(cha,n))
- } else {return(cha)}
- }
- w <- as.character(1:n)
- max0 <- max(nchar(w))
- w <- sapply(w, function(cha) f1(cha,max0))
- return(paste(base,w,sep=""))
-}
+## ###################
+## # Function .genlab
+## ###################
+## # recursive function to have labels of constant length
+## # base = a character string
+## # n = number of labels
+## .genlab <- function(base, n) {
+## f1 <- function(cha,n){
+## if(nchar(cha)<n){
+## cha <- paste("0",cha,sep="")
+## return(f1(cha,n))
+## } else {return(cha)}
+## }
+## w <- as.character(1:n)
+## max0 <- max(nchar(w))
+## w <- sapply(w, function(cha) f1(cha,max0))
+## return(paste(base,w,sep=""))
+## }
@@ -63,7 +63,7 @@
###############################################################
###############################################################
-#.initAdegenetClasses <- function(){
+##.initAdegenetClasses <- function(){
####################
@@ -86,6 +86,7 @@
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")
@@ -203,7 +204,7 @@
## check type of marker
if(!object at type %in% c("codom","domin") ){
- cat("\nunknowon type of marker\n")
+ cat("\nunknown type of marker\n")
return(FALSE)
}
@@ -241,6 +242,18 @@
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","domin") ){
+ cat("\nunknown type of marker\n")
+ return(FALSE)
+ }
+
return(TRUE)
} #end .genpop.valid
@@ -281,109 +294,106 @@
##################
## constructor of a genind object
genind <- function(tab,pop=NULL,prevcall=NULL,ploidy=2,type=c("codom","domin")){
+ ## 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)}
- 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)
- type <- match.arg(type)
+ ## labels for individuals
+ nind <- nrow(X)
+ ind.names <- .rmspaces(rownames(X))
+ ind.codes <- .genlab("", nind)
+ names(ind.names) <- ind.codes
- # labels for individuals
- nind <- nrow(X)
- ind.names <- .rmspaces(rownames(X))
- ind.codes <- .genlab("", nind)
- names(ind.names) <- ind.codes
+ ## labels for loci
+ ## and loc.nall
+ if(type=="codom"){
+ temp <- colnames(X)
+ temp <- gsub("[.].*$","",temp)
+ temp <- .rmspaces(temp)
+ ## beware !!! Function 'table' gives ordred output.
+ loc.names <- unique(temp)
+ loc.nall <- table(temp)[match(loc.names,names(table(temp)))]
+ loc.nall <- as.integer(loc.nall)
- # labels for loci
- # and loc.nall
- if(type=="codom"){
- temp <- colnames(X)
- temp <- gsub("[.].*$","",temp)
- temp <- .rmspaces(temp)
- ## beware !!! Function 'table' gives ordred output.
- loc.names <- unique(temp)
- loc.nall <- table(temp)[match(loc.names,names(table(temp)))]
- loc.nall <- as.integer(loc.nall)
+ nloc <- length(loc.names)
+ loc.codes <- .genlab("L",nloc)
- nloc <- length(loc.names)
- loc.codes <- .genlab("L",nloc)
+ names(loc.names) <- loc.codes
- names(loc.names) <- loc.codes
+ names(loc.nall) <- loc.codes
- names(loc.nall) <- loc.codes
+ ## loc.fac
+ loc.fac <- rep(loc.codes,loc.nall)
- ## 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]]
+ }
- ## 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) <- ind.codes
+ colnames(X) <- paste(loc.fac,unlist(all.codes),sep=".")
+ loc.fac <- as.factor(loc.fac)
+ } else { # end if type=="codom" <=> if type=="domin"
+ nloc <- ncol(X)
+ loc.codes <- .genlab("N", nloc)
+ colnames(X) <- loc.codes
+ loc.names <-colnames(X)
+ names(loc.names) <- loc.codes
+ loc.fac <- NULL
+ all.names <- NULL
+ loc.nall <- NULL
+ }
- rownames(X) <- ind.codes
- colnames(X) <- paste(loc.fac,unlist(all.codes),sep=".")
- loc.fac <- as.factor(loc.fac)
- } else { # end if type=="codom"
- nloc <- ncol(X)
- loc.codes <- .genlab("N", nloc)
- colnames(X) <- loc.codes
- loc.names <-colnames(X)
- names(loc.names) <- loc.codes
- loc.fac <- NULL
- all.names <- NULL
- loc.nall <- NULL
- }
- # This was used in S3 version
- #
- #res <- list( tab=X, ind.names=ind.names, loc.names=loc.names,
- # loc.nall=loc.nall, loc.fac=loc.fac, all.names=all.names )
+ ## 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
- # 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
+ }
- # 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
- ## 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)
- ## type of marker
- res at type <- as.character(type)
+ if(is.null(prevcall)) {prevcall <- match.call()}
+ res at call <- prevcall
- if(is.null(prevcall)) {prevcall <- match.call()}
- res at call <- prevcall
+ return(res)
- return(res)
-
} # end genind
######################
More information about the adegenet-commits
mailing list