[adegenet-commits] r640 - pkg/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri May 21 14:23:51 CEST 2010
Author: jombart
Date: 2010-05-21 14:23:51 +0200 (Fri, 21 May 2010)
New Revision: 640
Modified:
pkg/R/basicMethods.R
pkg/R/handling.R
pkg/R/seqTrack.R
pkg/R/zzz.R
Log:
tried dozens of solutions. Not working. Summary issue seems oddly fixed, but subsetting is not found - as if not sourced when loading the package.
Code is fine.
Trying to reorder the sources.
Collate field in package description used.
Modified: pkg/R/basicMethods.R
===================================================================
--- pkg/R/basicMethods.R 2010-05-20 15:19:13 UTC (rev 639)
+++ pkg/R/basicMethods.R 2010-05-21 12:23:51 UTC (rev 640)
@@ -124,9 +124,9 @@
############################
# Method summary for genind
############################
-if(!isGeneric("summary")){
- setGeneric("summary", function(object, ...) standardGeneric("summary"))
-}
+## if(!isGeneric("summary")){
+## setGeneric("summary", function(object, ...) standardGeneric("summary"))
+## }
setMethod ("summary", signature(object="genind"), function(object, ...){
x <- object
if(!is.genind(x)) stop("Provided object is not a valid genind.")
Modified: pkg/R/handling.R
===================================================================
--- pkg/R/handling.R 2010-05-20 15:19:13 UTC (rev 639)
+++ pkg/R/handling.R 2010-05-21 12:23:51 UTC (rev 640)
@@ -7,6 +7,149 @@
###########################
+
+
+
+
+setMethod("$","genpop",function(x,name) {
+ return(slot(x,name))
+})
+
+
+setMethod("$<-","genpop",function(x,name,value) {
+ slot(x,name,check=TRUE) <- value
+ return(x)
+})
+
+
+
+
+
+###############
+# '[' operator
+###############
+## genind
+setMethod("[", "genind",
+ function(x, i, j, ..., loc=NULL, treatOther=TRUE, drop=FALSE) {
+
+ if (missing(i)) i <- TRUE
+ if (missing(j)) j <- TRUE
+
+ pop <- NULL
+ if(is.null(x at pop)) { tab <- truenames(x) }
+ if(!is.null(x at pop)) {
+ temp <- truenames(x)
+ tab <- temp$tab
+ pop <- temp$pop
+ pop <- factor(pop[i])
+ }
+
+ ## handle loc argument
+ if(!is.null(loc)){
+ loc <- as.character(loc)
+ temp <- !loc %in% x at loc.fac
+ if(any(temp)) { # si mauvais loci
+ warning(paste("the following specified loci do not exist:", loc[temp]))
+ }
+ j <- x$loc.fac %in% loc
+ } # end loc argument
+
+ prevcall <- match.call()
+
+ tab <- tab[i, j, ...,drop=FALSE]
+
+ if(drop){
+ allNb <- apply(tab, 2, sum, na.rm=TRUE) # allele absolute frequencies
+ toKeep <- (allNb > 1e-10)
+ tab <- tab[,toKeep, drop=FALSE]
+ }
+
+ res <- genind(tab,pop=pop,prevcall=prevcall, ploidy=x at ploidy, type=x at type)
+
+ ## handle 'other' slot
+ nOther <- length(x at other)
+ namesOther <- names(x at other)
+ counter <- 0
+ if(treatOther){
+ f1 <- function(obj,n=nrow(x at tab)){
+ counter <<- counter+1
+ if(!is.null(dim(obj)) && nrow(obj)==n) { # if the element is a matrix-like obj
+ obj <- obj[i,,drop=FALSE]
+ } else if(length(obj) == n) { # if the element is not a matrix but has a length == n
+ obj <- obj[i]
+ if(is.factor(obj)) {obj <- factor(obj)}
+ } else {warning(paste("cannot treat the object",namesOther[counter]))}
+
+ return(obj)
+ } # end f1
+
+ res at other <- lapply(x at other, f1) # treat all elements
+
+ } # end treatOther
+
+ return(res)
+ })
+
+
+## genpop
+setMethod("[","genpop",
+ function(x, i, j, ..., loc=NULL, treatOther=TRUE, drop=FALSE) {
+
+ if (missing(i)) i <- TRUE
+ if (missing(j)) j <- TRUE
+
+ tab <- truenames(x)
+
+ ## handle loc argument
+ if(!is.null(loc)){
+ loc <- as.character(loc)
+ temp <- !loc %in% x at loc.fac
+ if(any(temp)) { # si mauvais loci
+ warning(paste("the following specified loci do not exist:", loc[temp]))
+ }
+ j <- x$loc.fac %in% loc
+ } # end loc argument
+
+ prevcall <- match.call()
+ tab <- tab[i, j, ...,drop=FALSE]
+
+ if(drop){
+ allNb <- apply(tab, 2, sum, na.rm=TRUE) # allele absolute frequencies
+ toKeep <- (allNb > 1e-10)
+ tab <- tab[,toKeep, drop=FALSE]
+ }
+
+ res <- genpop(tab,prevcall=prevcall)
+
+ ## handle 'other' slot
+ nOther <- length(x at other)
+ namesOther <- names(x at other)
+ counter <- 0
+ if(treatOther){
+ f1 <- function(obj,n=nrow(x at tab)){
+ counter <<- counter+1
+ if(!is.null(dim(obj)) && nrow(obj)==n) { # if the element is a matrix-like obj
+ obj <- obj[i,,drop=FALSE]
+ } else if(length(obj) == n) { # if the element is not a matrix but has a length == n
+ obj <- obj[i]
+ if(is.factor(obj)) {obj <- factor(obj)}
+ } else {warning(paste("cannot treat the object",namesOther[counter]))}
+
+ return(obj)
+ } # end f1
+
+ res at other <- lapply(x at other, f1) # treat all elements
+
+ } # end treatOther
+
+
+ return(res)
+ })
+
+
+
+
+
##############################
# Method truenames for genind
##############################
@@ -52,6 +195,8 @@
+
+
###########################
# Method seploc for genind
###########################
@@ -174,146 +319,11 @@
})
-setMethod("$","genpop",function(x,name) {
- return(slot(x,name))
-})
-setMethod("$<-","genpop",function(x,name,value) {
- slot(x,name,check=TRUE) <- value
- return(x)
-})
-
-
-###############
-# '[' operator
-###############
-## genind
-setMethod("[","genind",
- function(x, i, j, ..., loc=NULL, treatOther=TRUE, drop=FALSE) {
-
- if (missing(i)) i <- TRUE
- if (missing(j)) j <- TRUE
-
- pop <- NULL
- if(is.null(x at pop)) { tab <- truenames(x) }
- if(!is.null(x at pop)) {
- temp <- truenames(x)
- tab <- temp$tab
- pop <- temp$pop
- pop <- factor(pop[i])
- }
-
- ## handle loc argument
- if(!is.null(loc)){
- loc <- as.character(loc)
- temp <- !loc %in% x at loc.fac
- if(any(temp)) { # si mauvais loci
- warning(paste("the following specified loci do not exist:", loc[temp]))
- }
- j <- x$loc.fac %in% loc
- } # end loc argument
-
- prevcall <- match.call()
-
- tab <- tab[i, j, ...,drop=FALSE]
-
- if(drop){
- allNb <- apply(tab, 2, sum, na.rm=TRUE) # allele absolute frequencies
- toKeep <- (allNb > 1e-10)
- tab <- tab[,toKeep, drop=FALSE]
- }
-
- res <- genind(tab,pop=pop,prevcall=prevcall, ploidy=x at ploidy, type=x at type)
-
- ## handle 'other' slot
- nOther <- length(x at other)
- namesOther <- names(x at other)
- counter <- 0
- if(treatOther){
- f1 <- function(obj,n=nrow(x at tab)){
- counter <<- counter+1
- if(!is.null(dim(obj)) && nrow(obj)==n) { # if the element is a matrix-like obj
- obj <- obj[i,,drop=FALSE]
- } else if(length(obj) == n) { # if the element is not a matrix but has a length == n
- obj <- obj[i]
- if(is.factor(obj)) {obj <- factor(obj)}
- } else {warning(paste("cannot treat the object",namesOther[counter]))}
-
- return(obj)
- } # end f1
-
- res at other <- lapply(x at other, f1) # treat all elements
-
- } # end treatOther
-
- return(res)
- })
-
-
-## genpop
-setMethod("[","genpop",
- function(x, i, j, ..., loc=NULL, treatOther=TRUE, drop=FALSE) {
-
- if (missing(i)) i <- TRUE
- if (missing(j)) j <- TRUE
-
- tab <- truenames(x)
-
- ## handle loc argument
- if(!is.null(loc)){
- loc <- as.character(loc)
- temp <- !loc %in% x at loc.fac
- if(any(temp)) { # si mauvais loci
- warning(paste("the following specified loci do not exist:", loc[temp]))
- }
- j <- x$loc.fac %in% loc
- } # end loc argument
-
- prevcall <- match.call()
- tab <- tab[i, j, ...,drop=FALSE]
-
- if(drop){
- allNb <- apply(tab, 2, sum, na.rm=TRUE) # allele absolute frequencies
- toKeep <- (allNb > 1e-10)
- tab <- tab[,toKeep, drop=FALSE]
- }
-
- res <- genpop(tab,prevcall=prevcall)
-
- ## handle 'other' slot
- nOther <- length(x at other)
- namesOther <- names(x at other)
- counter <- 0
- if(treatOther){
- f1 <- function(obj,n=nrow(x at tab)){
- counter <<- counter+1
- if(!is.null(dim(obj)) && nrow(obj)==n) { # if the element is a matrix-like obj
- obj <- obj[i,,drop=FALSE]
- } else if(length(obj) == n) { # if the element is not a matrix but has a length == n
- obj <- obj[i]
- if(is.factor(obj)) {obj <- factor(obj)}
- } else {warning(paste("cannot treat the object",namesOther[counter]))}
-
- return(obj)
- } # end f1
-
- res at other <- lapply(x at other, f1) # treat all elements
-
- } # end treatOther
-
-
- return(res)
- })
-
-
-
-
-
-
##################
# Function seppop
##################
Modified: pkg/R/seqTrack.R
===================================================================
--- pkg/R/seqTrack.R 2010-05-20 15:19:13 UTC (rev 639)
+++ pkg/R/seqTrack.R 2010-05-21 12:23:51 UTC (rev 640)
@@ -321,6 +321,7 @@
##########################
## as("seqTrack", "graphNEL")
##########################
+if(require(graph)){
setOldClass("seqTrack")
setAs("seqTrack", "graphNEL", def=function(from){
if(!require(ape)) stop("package ape is required")
@@ -334,6 +335,7 @@
res <- ftM2graphNEL(ft=cbind(ori.labels[from$ances], ori.labels[from$id]), W=from$weight, edgemode = "directed", V=ori.labels)
return(res)
})
+}
Modified: pkg/R/zzz.R
===================================================================
--- pkg/R/zzz.R 2010-05-20 15:19:13 UTC (rev 639)
+++ pkg/R/zzz.R 2010-05-21 12:23:51 UTC (rev 640)
@@ -6,5 +6,4 @@
packageStartupMessage(startup.txt)
- require(methods)
}
More information about the adegenet-commits
mailing list