[adegenet-commits] r241 - pkg/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sun Jan 25 18:10:31 CET 2009
Author: jombart
Date: 2009-01-25 18:10:31 +0100 (Sun, 25 Jan 2009)
New Revision: 241
Modified:
pkg/R/auxil.R
pkg/R/import.R
pkg/R/makefreq.R
pkg/R/old2new.R
pkg/R/propShared.R
pkg/R/propTyped.R
Log:
again checktypes
Modified: pkg/R/auxil.R
===================================================================
--- pkg/R/auxil.R 2009-01-25 16:55:56 UTC (rev 240)
+++ pkg/R/auxil.R 2009-01-25 17:10:31 UTC (rev 241)
@@ -22,6 +22,20 @@
###################
+# Function readExt
+###################
+.readExt <- function(char){
+ temp <- as.character(char)
+ temp <- unlist(strsplit(char,"[.]"))
+ res <- temp[length(temp)]
+ return(res)
+}
+
+
+
+
+
+###################
# Function .genlab
###################
# recursive function to have labels of constant length
@@ -86,18 +100,29 @@
############
# checkType
############
-checkType <- function(x){
- markType <- x at type
+checkType <- function(markType=x at type){
+
if(markType=="codom") return() # always ok for codominant markers
currCall <- match.call()
currFunction <- sub("[[:space:]]*[(].*","",currCall)
## names of functions which are ok for dominant markers
- dominOk <- c("genind","genpop","genind2genpop","summary","na.replace","nLoc")
+ PAOk <- c("genind","genpop","genind2genpop","summary",
+ "truenames","seppop","na.replace","nLoc")
- if(! currFunction %in% dominOk){
- msgError <- paste(currFunction,"is not implemented for dominant markers")
+ PAWarn <- c("df2genind")
+
+ ## function exists but is experimental
+ if(currFunction %in% PAWarn){
+ msg <- paste(currFunction,"is implemented but experimental presence/absence markers")
+ warning(msg)
+ return()
+ }
+
+ ## function not implemented
+ if(! currFunction %in% PAOk){
+ msgError <- paste(currFunction,"is not implemented for presence/absence markers")
stop(msgError)
} else return() # else, ok.
} # end checkType
Modified: pkg/R/import.R
===================================================================
--- pkg/R/import.R 2009-01-25 16:55:56 UTC (rev 240)
+++ pkg/R/import.R 2009-01-25 17:10:31 UTC (rev 241)
@@ -13,30 +13,8 @@
##
##################################################################
-#######################
-# Function rmspaces
-#######################
-# removes spaces and tab at the begining and the end of each element of charvec
-.rmspaces <- function(charvec){
- charvec <- gsub("^([[:blank:]]+)","",charvec)
- charvec <- gsub("([[:blank:]]+)$","",charvec)
- return(charvec)
-}
-
-###################
-# Function readExt
-###################
-.readExt <- function(char){
- temp <- as.character(char)
- temp <- unlist(strsplit(char,"[.]"))
- res <- temp[length(temp)]
- return(res)
-}
-
-
-
#####################
# Function df2genind
#####################
@@ -47,10 +25,10 @@
res <- list()
type <- match.arg(type)
+ checkType(type)
## type PA
if(toupper(type)=="PA"){
- warning("experimental mode for presence/absence")
mode(X) <- "numeric"
## pop optionnelle
@@ -293,8 +271,8 @@
########################################
read.genetix <- function(file=NULL,missing=NA,quiet=FALSE) {
if(!quiet) cat("\n Converting data from GENETIX to a genind object... \n")
+
-
## read from file
## if(!file.exists(file)) stop("Specified file does not exist.") <- not needed
Modified: pkg/R/makefreq.R
===================================================================
--- pkg/R/makefreq.R 2009-01-25 16:55:56 UTC (rev 240)
+++ pkg/R/makefreq.R 2009-01-25 17:10:31 UTC (rev 241)
@@ -4,7 +4,8 @@
makefreq <- function(x,quiet=FALSE,missing=NA,truenames=TRUE){
if(!is.genpop(x)) stop("x is not a valid genpop object")
- if(x at type=="PA") stop("frequencies not computable for presence/asbence data")
+ ##if(x at type=="PA") stop("frequencies not computable for presence/asbence data")
+ checkType(x)
if(!quiet) cat("\n Finding allelic frequencies from a genpop object... \n")
Modified: pkg/R/old2new.R
===================================================================
--- pkg/R/old2new.R 2009-01-25 16:55:56 UTC (rev 240)
+++ pkg/R/old2new.R 2009-01-25 17:10:31 UTC (rev 241)
@@ -7,7 +7,7 @@
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)
@@ -24,6 +24,7 @@
}
res at call <- match.call()
res at ploidy <- as.integer(2)
+ res at type <- "codom"
if(length(object) > theoLength) warning("optional content else than pop and pop.names was not converted")
@@ -41,8 +42,11 @@
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 ploidy <- as.integer(2)
+ res at type <- "codom"
+
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 2009-01-25 16:55:56 UTC (rev 240)
+++ pkg/R/propShared.R 2009-01-25 17:10:31 UTC (rev 241)
@@ -7,15 +7,16 @@
######################
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))
## 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")
@@ -25,13 +26,13 @@
## 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
@@ -47,19 +48,19 @@
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
@@ -78,20 +79,20 @@
## ## 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)
+## return(vec)
## }
-
+
## ## auxiliary function f1
## ## computes the proportion of shared alleles in one locus
## f1 <- function(X){
@@ -100,11 +101,11 @@
## 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){
@@ -112,10 +113,10 @@
## res <- res + listProp[[i]]
## }
## }
-
+
## res <- res/nloc
## rownames(res) <- x at ind.names
## colnames(res) <- x at ind.names
-
+
## return(res)
## }
Modified: pkg/R/propTyped.R
===================================================================
--- pkg/R/propTyped.R 2009-01-25 16:55:56 UTC (rev 240)
+++ pkg/R/propTyped.R 2009-01-25 17:10:31 UTC (rev 241)
@@ -9,6 +9,7 @@
setMethod("propTyped","genind", function(x, by=c("ind","loc","both")){
+ checkType(x)
by <- match.arg(by)
## auxil function f1
@@ -44,8 +45,10 @@
+
setMethod("propTyped","genpop", function(x, by=c("pop","loc","both")){
+ checkType(x)
by <- match.arg(by)
## auxil function f1
More information about the adegenet-commits
mailing list