[Zooimage-commits] r87 - pkg/zooimage/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mon Apr 20 16:48:10 CEST 2009
Author: romain
Date: 2009-04-20 16:48:10 +0200 (Mon, 20 Apr 2009)
New Revision: 87
Modified:
pkg/zooimage/R/ZIClass.r
pkg/zooimage/R/ZIRes.r
pkg/zooimage/R/ZITrain.r
pkg/zooimage/R/utilities.r
Log:
using mustbe instead of if(!inherits()
Modified: pkg/zooimage/R/ZIClass.r
===================================================================
--- pkg/zooimage/R/ZIClass.r 2009-04-20 14:25:14 UTC (rev 86)
+++ pkg/zooimage/R/ZIClass.r 2009-04-20 14:48:10 UTC (rev 87)
@@ -86,6 +86,7 @@
# {{{ print.ZIClass
"print.ZIClass" <- function(x, ...) {
+
algorithm <- attr(x, "algorithm")
classes <- attr(x, "classes")
lclasses <- levels(classes)
@@ -239,7 +240,7 @@
# {{{ confusion.bar
# New function v 1.2-2 false positive and negative
confusion.bar <- function(confmat, mar=NULL) {
- if (is.matrix(confmat) == FALSE){
+ if ( !is.matrix(confmat) ){
stop("object must be a matrix")
}
Nn <- nrow(confmat)
@@ -292,14 +293,14 @@
barplot(all2[,!is.na(all2[2,])], horiz=TRUE,
col=c("PeachPuff2", "green3", "green3", "lemonChiffon2"),
xaxt="n", las=1, space = 0)
- for (i in 1:Nmat) {
- text(valx[i,],i-0.45, Failure.mat[i,] , cex=0.7)
- text(valx2[i,],i-0.45, 100 - Failure.mat[i,] , cex=0.7)
- }
+ text(valx[i,] , row(valx) - 0.45 , Failure.mat , cex=0.7)
+ text(valx2[i,] , row(valx2)- 0.45 , 100 - Failure.mat , cex=0.7)
#### Ajout des légendes
- legend(100, Nmat+(Nmat/15), legend = c("false negative (FN)", "correct ident (CI)", "false positive (FP)"),
- xjust = 0.5, fill = c("PeachPuff2", "green3", "lemonChiffon2"), bty="n", horiz = TRUE)
+ legend(100, Nmat+(Nmat/15),
+ legend = c("false negative (FN)", "correct ident (CI)", "false positive (FP)"),
+ xjust = 0.5, fill = c("PeachPuff2", "green3", "lemonChiffon2"),
+ bty="n", horiz = TRUE)
legend(100, Nmat/55, "Percentage", xjust = 0.5, bty = "n")
segx0 <- rep(c(25, 50, 75, 125, 150, 175),2)
segy0 <- rep(c(0, Nmat),c(6,6))
@@ -324,16 +325,17 @@
# }}}
# {{{ predict.nnet2
-"predict.nnet2" <-
- function (object, newdata, type = c("raw", "class"), ...) {
- if (!inherits(object, "nnet2"))
- stop("object not of class \"nnet2\"")
+"predict.nnet2" <- function (object, newdata, type = c("raw", "class"), ...) {
+
+ mustbe( object, "nnet2" )
+
(require(nnet) || stop("package 'nnet' is required!"))
- class(object) <-class(object)[-1]
+ class(object) <- class(object)[-1]
res <- predict(object, newdata = newdata, type = type, ...)
# If type is class, we got a character vector... but should get a factor
- if (type == "class")
+ if (type == "class"){
res <- factor(res, levels = object$lev)
+ }
return(res)
}
# }}}
Modified: pkg/zooimage/R/ZIRes.r
===================================================================
--- pkg/zooimage/R/ZIRes.r 2009-04-20 14:25:14 UTC (rev 86)
+++ pkg/zooimage/R/ZIRes.r 2009-04-20 14:48:10 UTC (rev 87)
@@ -26,8 +26,7 @@
if (!file.exists(ZidFile)) {
logProcess("file not found!", ZidFile, stop = TRUE, show.log = show.log); return(invisible(FALSE)) }
# Check if ZIClass is of the right class
- if (!inherits(ZIClass, "ZIClass")) {
- logProcess("ZIClass is not a 'ZIClass' object!", stop = TRUE, show.log = show.log); return(invisible(FALSE)) }
+ mustbe(ZIClass, "ZIClass")
# Get ZIDat from the ZidFile
ZIDat <- read.zid(ZidFile)
Sample <- get.sampleinfo(ZidFile, type = "sample", ext = "[.][zZ][iI][dD]$")
@@ -133,15 +132,16 @@
return(restot)
}
-"Spectrum.sample" <-
- function(ZIDat, sample, taxa = NULL, groups = NULL,
+# {{{ Spectrum.sample
+#' Cut a sample into ECD classes (for size spectra)
+"Spectrum.sample" <- function(ZIDat, sample, taxa = NULL, groups = NULL,
breaks = seq(0.25, 2, by = 0.1), use.Dil = TRUE) {
- # Cut a sample into ECD classes (for size spectra)
+
# Check arguments
- if (!inherits(ZIDat, "ZIDat"))
- stop("ZIDat must be a 'ZIDat' object")
+ mustbe(ZIDat, "ZIDat")
if (!is.character(sample) && length(sample) != 1)
stop("sample must be a character string of length one")
+
# Extract only data for a given sample
Smps <- sub("[+].*", "", as.character(ZIDat$Label)) # Sample is everything before a '+' sign
if (!sample %in% unique(Smps))
@@ -156,13 +156,14 @@
}
return(res)
}
+# }}}
"Spectrum" <-
function(ZIDat, image, taxa = NULL, groups = NULL,
breaks = seq(0.25, 2, by = 0.1), use.Dil = TRUE) {
+
# Check arguments
- if (!inherits(ZIDat, "ZIDat"))
- stop("ZIDat must be a 'ZIDat' object")
+ mustbe(ZIDat, "ZIDat")
if (!is.character(image) && length(image) != 1)
stop("image must be a character string of length one")
dat <- ZIDat[ZIDat$Label == image, ] # Select the image
@@ -205,8 +206,8 @@
conv = c(1, 0, 1), header = "Bio", exportdir = NULL) {
# Convert ECD (biomass calculation, etc.)
# Check arguments
- if (!inherits(ZIDat, "ZIDat"))
- stop("ZIDat must be a 'ZIDat' object")
+ mustbe(ZIDat, "ZIDat" )
+
if (!is.character(sample) && length(sample) != 1)
stop("sample must be a character string of length one")
# Extract only data for a given sample
@@ -295,31 +296,34 @@
return(res)
}
-"Abd.sample" <-
- function(ZIDat, sample, taxa = NULL, groups = NULL,
+#{{{ Abd.sample
+#' Calculate abundances for various taxa in a sample
+"Abd.sample" <- function(ZIDat, sample, taxa = NULL, groups = NULL,
type = c("absolute", "log", "relative"), header = "Abd") {
- # Calculate abundances for various taxa in a sample
+
# Check arguments
- if (!inherits(ZIDat, "ZIDat"))
- stop("ZIDat must be a 'ZIDat' object")
+ mustbe( ZIDat, "ZIDat")
if (!is.character(sample) && length(sample) != 1)
stop("sample must be a character string of length one")
- type <- type[1]
- if (!(type %in% c("absolute", "log", "relative")))
- stop("type must be 'absolute', 'log' or 'relative'")
+ type <- match.arg( type, several.ok = FALSE )
+
# Extract only data for a given sample
Smps <- sub("[+].*", "", as.character(ZIDat$Label)) # Sample is everything before a '+' sign
- if (!sample %in% unique(Smps))
+ if (!sample %in% unique(Smps)){
stop("sample '", sample, "' is not in ZIDat")
+ }
Smp <- ZIDat[Smps == sample, ]
+
# Subsample, depending on taxa we keep
if (!is.null(taxa)) {
if (!all(taxa %in% levels(Smp$Ident)))
stop("taxa not in the sample")
Smp <- Smp[Smp$Ident %in% taxa, ] # Select taxa
}
- if (nrow(Smp) == 0)
+ if (nrow(Smp) == 0){
stop("no data for this sample/taxa in ZIDat")
+ }
+
# If relative abundance, calculation of fraction for each individual
if (type == "relative") {
Table <- table(Smp$Dil)
@@ -352,41 +356,39 @@
res <- log10(res + 1)
return(res)
}
+# }}}
"plot.ZITable" <-
function(x, y, ...) {
barplot(x, names.arg = attr(x, "breaks")[-1], ...)
}
-"merge.ZITable" <-
- function(x, y, ...) {
- if (!inherits(x, "ZITable"))
- stop("x must be a 'ZITable' object")
- if (!inherits(y, "ZITable"))
- stop("y must be a 'ZITable' object")
+"merge.ZITable" <- function(x, y, ...) {
+
+ mustbe(x, "ZITable")
+ mustbe(y, "ZITable")
+
breaks.x <- attr(x, "breaks")
breaks.y <- attr(y, "breaks")
- if (!all(breaks.x == breaks.y))
- stop("breaks of all objects must match")
+ mustmatch( breaks.x, breaks.y,
+ "breaks of all objects must match")
+
unit.x <- attr(x, "unit")
unit.y <- attr(y, "unit")
- if (!unit.x == unit.y)
- stop("units of all objects must match")
+ mustmatch( unit.x, unit.y, "units of all objects must match")
res <- x + y
+
# If the user provides more tables, merge them all
moreargs <- list(...)
if (length(moreargs) > 0) {
# Merge all provided tables
for (i in 1:length(moreargs)) {
- tt <- moreargs[[i]]
- if (!inherits(tt, "ZITable"))
- stop("all arguments must be 'ZITable' objects")
+ tt <- moreargs[[i]]
+ mustbe( tt, "ZITable", msg = "all arguments must be 'ZITable' objects")
breaks.tt <- attr(tt, "breaks")
- if (!all(breaks.x == breaks.tt))
- stop("breaks of all objects must match")
+ mustmatch( breaks.x, breaks.tt, "breaks of all objects must match")
unit.tt <- attr(tt, "unit")
- if (!unit.x == unit.tt)
- stop("units of all objects must match")
+ mustmatch( unit.x, unit.tt, "units of all objects must match")
res <- res + tt
}
}
@@ -444,3 +446,5 @@
if (!is.null(xleg)) legend(xleg, yleg, legend, col = cols,
lwd = 1, pch = pchs, bg = "white")
}
+# :tabSize=4:indentSize=4:noTabs=false:folding=explicit:collapseFolds=1:
+
Modified: pkg/zooimage/R/ZITrain.r
===================================================================
--- pkg/zooimage/R/ZITrain.r 2009-04-20 14:25:14 UTC (rev 86)
+++ pkg/zooimage/R/ZITrain.r 2009-04-20 14:48:10 UTC (rev 87)
@@ -203,12 +203,8 @@
"recode.ZITrain" <- function(ZITrain, ZIRecode, warn.only = FALSE) {
# check classes
- if (!inherits(ZITrain, "ZITrain")){
- stop("ZITrain must be an object of class 'ZITrain'")
- }
- if (!inherits(ZIRecode, "ZIRecode")){
- stop("ZIRecode must be an object of class 'ZIRecode'")
- }
+ mustbe(ZITrain, "ZITrain")
+ mustbe(ZIRecode, "ZIRecode")
# Check that all levels in ZITrain$Class are represented in ZIRecode
if (!all(sort(levels(ZITrain$Class)) == sort(ZIRecode[ , 1]))) {
@@ -240,9 +236,7 @@
# {{{ make.ZIRecode.level
"make.ZIRecode.level" <- function(ZITrain, level = 1) {
# check class
- if (!inherits(ZITrain, "ZITrain")){
- stop("ZITrain must be an object of class 'ZITrain'")
- }
+ mustbe( ZITrain, "ZITrain")
# Get the "path" attribute
Path <- attr(ZITrain, "path")
Modified: pkg/zooimage/R/utilities.r
===================================================================
--- pkg/zooimage/R/utilities.r 2009-04-20 14:25:14 UTC (rev 86)
+++ pkg/zooimage/R/utilities.r 2009-04-20 14:48:10 UTC (rev 87)
@@ -77,9 +77,11 @@
Filter <- rep(TRUE, length(varlist))
for (i in 1:length(varlist)){
Var <- get(varlist[i])
- for (j in 1:length(Var))
- if (!inherits(Var[[j]], class))
+ for (j in 1:length(Var)){
+ if (!inherits(Var[[j]], class)){
Filter[i] <- FALSE
+ }
+ }
}
varlist <- varlist[Filter] # Keep only those objects
if (length(varlist) == 0) { # No such objects in .GlobalEnv
@@ -741,11 +743,25 @@
# }}}
-mustbe <- function( x, class ){
+mustbe <- function( x, class, msg ){
if( !any( sapply( class, function( cl ) inherits( x, cl) ) ) )
- stop( "x must be of one of these classes: ", paste( class, collapse = ", ") )
+ if( length(class) == 1){
+ if( missing(msg) ) msg <- sprintf( "x must be a '%s' object" , as.character(class) )
+ stop( msg )
+ } else{
+ if( missing(msg) ) msg <- paste( "x must be of one of these classes: ", paste( class, collapse = ", "), sep = "" )
+ stop( msg )
+ }
}
+mustmatch <- function( x, y, msg ){
+ if( !all( x == y ) ){
+ if( missing(msg) ) msg <- sprintf( "'%s' and '%s' must match", deparse(substitute(x)), deparse(substitute(y)) )
+ stop( msg )
+ }
+}
+
+
# a version that stops
require <- function( ... ){
withCallingHandlers( base:::require(...),
More information about the Zooimage-commits
mailing list