[adegenet-commits] r276 - pkg/R

[noreply at r-forge.r-project.org]

Author: jombart
Date: 2009-04-01 13:07:15 +0200 (Wed, 01 Apr 2009)
New Revision: 276

Modified:
   pkg/R/auxil.R
   pkg/R/handling.R
Log:
seploc fixed for PA


Modified: pkg/R/auxil.R
===================================================================
--- pkg/R/auxil.R	2009-04-01 10:41:58 UTC (rev 275)
+++ pkg/R/auxil.R	2009-04-01 11:07:15 UTC (rev 276)
@@ -100,6 +100,9 @@
 ############
 # checkType
 ############
+##
+## WARNING: this does not work with all S3/S4 methods
+##
 checkType <- function(x){
     if(is.character(x)){
         markType <- x
@@ -111,6 +114,10 @@
 
     currCall <- as.character(sys.call(sys.parent()))[1]
     currFunction <- sub("[[:space:]]*[(].*","",currCall)
+    if(currFunction==".local"){
+        warning("Current call not found - stopping check (please report this warning).")
+        return()
+    }
 
     ## names of functions which are ok for dominant markers
     PAOk <- c("genind","genpop","genind2genpop","summary","df2genind",
@@ -132,3 +139,4 @@
     } else return() # else, ok.
 } # end checkType
 
+

Modified: pkg/R/handling.R
===================================================================
--- pkg/R/handling.R	2009-04-01 10:41:58 UTC (rev 275)
+++ pkg/R/handling.R	2009-04-01 11:07:15 UTC (rev 276)
@@ -17,8 +17,7 @@
     X <- x at tab
     if(!all(x at ind.names=="")) {rownames(X) <- x at ind.names}
 
-    labcol <- rep(x at loc.names,x at loc.nall)
-    labcol <- paste(labcol,unlist(x at all.names),sep=".")
+    labcol <- locNames(x, withAlleles=TRUE)
     colnames(X) <- labcol
 
     if(!is.null(x at pop)){
@@ -44,8 +43,7 @@
     X <- x at tab
     if(!all(x at pop.names=="")) {rownames(X) <- x at pop.names}
 
-    labcol <- rep(x at loc.names,x at loc.nall)
-    labcol <- paste(labcol,unlist(x at all.names),sep=".")
+    labcol <- locNames(x, withAlleles=TRUE)
     colnames(X) <- labcol
 
     return(X)
@@ -60,8 +58,13 @@
 setGeneric("seploc", function(x, ...) standardGeneric("seploc"))
 
 setMethod("seploc", signature(x="genind"), function(x,truenames=TRUE,res.type=c("genind","matrix")){
-    checkType(x)
+    if(x at type=="PA"){
+        msg <- paste("seploc is not implemented for presence/absence markers")
+        cat("\n",msg,"\n")
+        return(invisible())
+    }
 
+
     if(!is.genind(x)) stop("x is not a valid genind object")
     res.type <- match.arg(res.type)
     if(res.type=="genind") { truenames <- TRUE }
@@ -107,8 +110,13 @@
 # Method seploc for genpop
 ###########################
 setMethod("seploc", signature(x="genpop"), function(x,truenames=TRUE,res.type=c("genpop","matrix")){
-    checkType(x)
+     if(x at type=="PA"){
+         msg <- paste("seploc is not implemented for presence/absence markers")
+         cat("\n",msg,"\n")
+         return(invisible())
+    }
 
+
     if(!is.genpop(x)) stop("x is not a valid genpop object")
     res.type <- match.arg(res.type)
     if(res.type=="genpop") { truenames <- TRUE }
@@ -359,7 +367,7 @@
 
 ## genind method
 setMethod("na.replace", signature(x="genind"), function(x,method, quiet=FALSE){
-    checkType(x)
+    ## checkType(x)
 
     ## preliminary stuff
     validObject(x)
@@ -400,7 +408,7 @@
 
 ## genpop method
 setMethod("na.replace", signature(x="genpop"), function(x,method, quiet=FALSE){
-    checkType(x)
+    ## checkType(x)
 
     ## preliminary stuff
     validObject(x)