[Zooimage-commits] r88 - pkg/zooimage/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mon Apr 20 17:21:59 CEST 2009
Author: romain
Date: 2009-04-20 17:21:59 +0200 (Mon, 20 Apr 2009)
New Revision: 88
Modified:
pkg/zooimage/R/ZIClass.r
pkg/zooimage/R/ZIRes.r
pkg/zooimage/R/programs.R
pkg/zooimage/R/utilities.r
pkg/zooimage/R/zie.r
Log:
more cleaning
Modified: pkg/zooimage/R/ZIClass.r
===================================================================
--- pkg/zooimage/R/ZIClass.r 2009-04-20 14:48:10 UTC (rev 87)
+++ pkg/zooimage/R/ZIClass.r 2009-04-20 15:21:59 UTC (rev 88)
@@ -240,9 +240,7 @@
# {{{ confusion.bar
# New function v 1.2-2 false positive and negative
confusion.bar <- function(confmat, mar=NULL) {
- if ( !is.matrix(confmat) ){
- stop("object must be a matrix")
- }
+ mustbe(confmat, "matrix" )
Nn <- nrow(confmat)
## percent of correctly predicted objects in the test set
Modified: pkg/zooimage/R/ZIRes.r
===================================================================
--- pkg/zooimage/R/ZIRes.r 2009-04-20 14:48:10 UTC (rev 87)
+++ pkg/zooimage/R/ZIRes.r 2009-04-20 15:21:59 UTC (rev 88)
@@ -139,42 +139,44 @@
# Check arguments
mustbe(ZIDat, "ZIDat")
- if (!is.character(sample) && length(sample) != 1)
- stop("sample must be a character string of length one")
+ mustbeString( sample, 1 )
# 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, ]
# Determine the number of images in this sample
imgs <- unique(ZIDat$Label)
res <- Spectrum(Smp, imgs[1], taxa = taxa, groups = groups, breaks = breaks, use.Dil = use.Dil)
if (length(imgs) > 1) {
- for (i in 2:length(imgs))
- res <- list.add(res, Spectrum(Smp, imgs[i], taxa = taxa, groups = groups, breaks = breaks, use.Dil = use.Dil))
+ for (i in 2:length(imgs)){
+ res <- list.add(res, Spectrum(Smp, imgs[i], taxa = taxa, groups = groups, breaks = breaks, use.Dil = use.Dil))
+ }
}
return(res)
}
# }}}
-"Spectrum" <-
- function(ZIDat, image, taxa = NULL, groups = NULL,
+# {{{ Spectrum
+"Spectrum" <- function(ZIDat, image, taxa = NULL, groups = NULL,
breaks = seq(0.25, 2, by = 0.1), use.Dil = TRUE) {
# Check arguments
mustbe(ZIDat, "ZIDat")
- if (!is.character(image) && length(image) != 1)
- stop("image must be a character string of length one")
+ mustbeString( image, 1)
dat <- ZIDat[ZIDat$Label == image, ] # Select the image
- if (nrow(dat) == 0)
+ if (nrow(dat) == 0){
warning("ZIDat contains no '", image, "' data!")
+ }
# Remember dilution (in case there are no data)
if (nrow(dat) > 0) Dil <- dat$Dil[1] else Dil <- 1
# taxa must correspond to levels in ZIDat$Ident
if (!is.null(taxa)) {
- if (!all(taxa %in% levels(dat$Ident)))
+ if (!all(taxa %in% levels(dat$Ident))){
stop("taxa not in ZIDat")
+ }
dat <- dat[dat$Ident %in% taxa, ] # Select taxa
}
if (is.null(groups)) {
@@ -182,8 +184,7 @@
groups <- list("")
names(groups) <- "total"
}
- if (!is.list(groups))
- stop("groups must be a list")
+ mustbe( groups, "list" )
res <- list()
gnames <- names(groups)
for (i in 1: length(groups)) {
@@ -200,29 +201,30 @@
attr(res, "unit") <- if(use.Dil) "ind/m^3" else "count"
return(res)
}
+# }}}
-"Bio.sample" <-
- function(ZIDat, sample, taxa = NULL, groups = NULL,
+# {{{ Bio.sample
+#' Convert ECD (biomass calculation, etc.)
+"Bio.sample" <- function(ZIDat, sample, taxa = NULL, groups = NULL,
conv = c(1, 0, 1), header = "Bio", exportdir = NULL) {
- # Convert ECD (biomass calculation, etc.)
+
# Check arguments
mustbe(ZIDat, "ZIDat" )
-
- if (!is.character(sample) && length(sample) != 1)
- stop("sample must be a character string of length one")
+ mustbeString( sample, 1 )
+
# Extract only data for a given sample
Smps <- sub("[+].*", "", as.character(ZIDat$Label)) # Sample is everything before a '+' sign
- if (!sample %in% unique(Smps))
- stop("sample '", sample, "' is not in ZIDat")
+ mustcontain( unique(Smps), sample,
+ msg = paste("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")
+ mustcontain( levels(Smp$Ident), taxa, "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")
+ }
# Add P1/P2/P3 conversion params to the table
if (inherits(conv, "data.frame")) {
if ( ! all(names(conv)[1:4] == c("Group", "P1", "P2", "P3") ) || !all(names(conv)[1:4] == c("Group", "a", "b", "c") ) ){
@@ -231,6 +233,7 @@
IdSmp <- as.character(Smp$Ident)
IdSmpU <- unique(IdSmp)
IdConv <- as.character(conv$Group)
+
# Eliminate [other] from the table and the list and keep its values for further use
IsOther <- (IdConv == "[other]")
Other <- conv[IsOther, ]
@@ -281,8 +284,7 @@
res <- sum(Smp$Biomass)
names(res) <- header
} else {
- if (!is.list(groups))
- stop("groups must be a list")
+ mustbe( groups, "list" )
res <- NULL
for (i in 1: length(groups)) {
if (length(groups[[i]]) == 1 && groups[[i]] == "") { # Total biomass
@@ -295,6 +297,7 @@
}
return(res)
}
+# }}}
#{{{ Abd.sample
#' Calculate abundances for various taxa in a sample
@@ -303,8 +306,7 @@
# Check arguments
mustbe( ZIDat, "ZIDat")
- if (!is.character(sample) && length(sample) != 1)
- stop("sample must be a character string of length one")
+ mustbeString( sample, 1 )
type <- match.arg( type, several.ok = FALSE )
# Extract only data for a given sample
@@ -340,8 +342,7 @@
res <- sum(Smp$Coef)
names(res) <- header
} else {
- if (!is.list(groups))
- stop("groups must be a list")
+ mustbe( groups, "list" )
res <- NULL
for (i in 1: length(groups)) {
if (length(groups[[i]]) == 1 && groups[[i]] == "") { # Total abundance
@@ -358,11 +359,13 @@
}
# }}}
-"plot.ZITable" <-
- function(x, y, ...) {
+# {{{ plot.ZITable
+"plot.ZITable" <- function(x, y, ...) {
barplot(x, names.arg = attr(x, "breaks")[-1], ...)
}
+# }}}
+# {{{ merge.ZITable
"merge.ZITable" <- function(x, y, ...) {
mustbe(x, "ZITable")
@@ -396,12 +399,14 @@
# coef divides and calculates the mean value
return(res)
}
+# }}}
-"histSpectrum" <-
- function(spect, class = 1:18 * 0.3 / 3 + 0.2, lag = 0.25, log.scale = TRUE,
+# {{{ histSpectrum
+"histSpectrum" <- function(spect, class = 1:18 * 0.3 / 3 + 0.2, lag = 0.25, log.scale = TRUE,
width = 0.1, xlab = "classes (mm)",
ylab = if (log.scale) "log(abundance + 1)/m^3" else "Abundance (ind./m^3",
main = "", ylim = c(0, 2), plot.exp = FALSE) {
+
# Plot of histograms and optionally line for exponential decrease for size spectra
if (plot.exp) {
spect.lm <- lm(spect ~ class)
@@ -425,26 +430,31 @@
return(invisible(spect.lm2))
}
}
+# }}}
-"plotAbdBio" <-
- function (t, y1, y2, y3, ylim = c(0,3),
+# {{{ plotAbdBio
+"plotAbdBio" <- function (t, y1, y2, y3, ylim = c(0,3),
xlab = "Date", ylab = "log(abundance + 1)", main = "",
cols = c("green", "blue", "red"), pchs = 1:3,
hgrid = 1:3, vgrid = t, vline = NULL, xleg = min(vgrid), yleg = ylim[2],
legend = c("series 1", "series 2", "series 3"), type = "o") {
+
# Custom plot for abundance and biomass
plot(t, y1, type = type, ylim = ylim, xlim = range(vgrid), ylab = ylab,
xlab = xlab, main = main, col = cols[1], xaxt = "n", pch = pchs[1])
axis(1, at = vgrid, label = format(vgrid, "%b"))
lines(t, y2, type = type, col = cols[2], pch = pchs[2])
lines(t, y3, type = type, col = cols[3], pch = pchs[3])
+
# Grid
abline(h = hgrid, col = "gray", lty = 2)
abline(v = vgrid, col = "gray", lty = 2)
+
# Vertical line(s) to spot particular time events
if (!is.null(vline)) abline(v = as.Date(vline), lty = 2, lwd = 2, col = 2)
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/programs.R
===================================================================
--- pkg/zooimage/R/programs.R 2009-04-20 14:48:10 UTC (rev 87)
+++ pkg/zooimage/R/programs.R 2009-04-20 15:21:59 UTC (rev 88)
@@ -87,6 +87,7 @@
}
misc_dcraw <- function( file, arguments, output){
+ checkCapable( "dc_raw" )
out <- try( misc( "dc_raw", '"%s" %s > "%s" ', file, args, output ), silent = T )
if( out %of% "try-error" ){
stop( sprintf("error converting '%s' with dc_raw", file ) )
Modified: pkg/zooimage/R/utilities.r
===================================================================
--- pkg/zooimage/R/utilities.r 2009-04-20 14:48:10 UTC (rev 87)
+++ pkg/zooimage/R/utilities.r 2009-04-20 15:21:59 UTC (rev 88)
@@ -276,6 +276,8 @@
#' All sample with at least one entry in a given object
"list.samples" <- function(obj) {
+ mustbe( obj, c("ZIDat", "ZIDesc","ZITrain") )
+
# List all samples represented in a given object
if (inherits(obj, "ZIDat")) {
res <- sort(unique(get.sampleinfo(as.character(obj$Label), type = "sample", ext = "")))
@@ -290,8 +292,6 @@
return(res)
}
- # Not a recognized object
- stop("'obj' must be a 'ZIDat', 'ZIDesc' or or 'ZITrain' object!")
}
# }}}
@@ -386,10 +386,8 @@
#' Merge two lists of data frames
"list.merge" <- function(x, y) {
- if (!inherits(x, "list"))
- stop("'x' must be a 'list'!")
- if (!inherits(y, "list"))
- stop("'y' must be a 'list'!")
+ mustbe( x, "list" )
+ mustbe( y, "list" )
xitems <- names(x)
yitems <- names(y)
@@ -427,12 +425,10 @@
# {{{ Add items across two lists (names must be the same)
"list.add" <- function(x, y) {
- if (!inherits(x, "list"))
- stop("'x' must be a 'list'!")
- if (!inherits(y, "list"))
- stop("'y' must be a 'list'!")
- if (!all(names(x) == names(y)))
- stop("names of two lists must match!")
+
+ mustbe(x, "list")
+ mustbe(y, "list")
+ mustmatch( names(x), names(y), "names of two lists must match!")
res <- x
for (i in 1:length(x)){
res[[i]] <- x[[i]] + y[[i]]
@@ -746,10 +742,14 @@
mustbe <- function( x, class, msg ){
if( !any( sapply( class, function( cl ) inherits( x, cl) ) ) )
if( length(class) == 1){
- if( missing(msg) ) msg <- sprintf( "x must be a '%s' object" , as.character(class) )
+ if( missing(msg) ) {
+ msg <- sprintf( "'%s' must be a '%s' object" , deparse( substitute(x)) , as.character(class) )
+ }
stop( msg )
} else{
- if( missing(msg) ) msg <- paste( "x must be of one of these classes: ", paste( class, collapse = ", "), sep = "" )
+ if( missing(msg) ){
+ msg <- paste( "'%s' must be of one of these classes: ", deparse( substitute(x)), paste( class, collapse = ", "), sep = "" )
+ }
stop( msg )
}
}
@@ -761,7 +761,25 @@
}
}
+mustcontain <- function( container, element, msg ){
+ if( ! all(element %in% container) ){
+ if( missing(msg) ){
+ msg <- sprintf( "'%s' must contain '%s'", deparse( substitute( container)), deparse(substitute(element)) )
+ stop( msg )
+ }
+ }
+}
+mustbeString <- function( x, length){
+ if( !is.character( x ) ){
+ stop( sprintf( "%s must be a character string", deparse( substitute(x)) ) )
+ }
+ if( !missing(length) && !length(x) == length ){
+ stop( sprintf( "%s must be a character string of length %d", deparse( substitute(x)), length ) )
+ }
+}
+
+
# a version that stops
require <- function( ... ){
withCallingHandlers( base:::require(...),
Modified: pkg/zooimage/R/zie.r
===================================================================
--- pkg/zooimage/R/zie.r 2009-04-20 14:48:10 UTC (rev 87)
+++ pkg/zooimage/R/zie.r 2009-04-20 15:21:59 UTC (rev 88)
@@ -38,24 +38,25 @@
"ZIE" <- function(title, filter, description, pattern, command, author, version, date,
license, url, depends = "R (>= 2.4.0), zooimage (>= 1.0-0)",
type = c("import", "export")) {
+
if (!is.character(title) || !is.character(filter) || !is.character(description) ||
!is.character(pattern) || !is.character(command) || !is.character(author) ||
!is.character(version) || !is.character(date) || !is.character(license) ||
- !is.character(url) || !is.character(depends))
+ !is.character(url) || !is.character(depends)){
stop("All arguments must be character strings!")
+ }
obj <- list(title = title[1], filter = filter[1],
description = paste(description, collapse = "\n"), pattern = pattern[1],
command = paste(command, collapse = "\n"), author = author[1],
version = version[1], license = license[1], depends = depends[1])
- class(obj) <- switch(type[1],
+ type <- match.arg( type, several.ok = FALSE )
+ class(obj) <- switch(type,
import = c("ZIEimport", "ZIE"),
- export = c("ZIEexport", "ZIE"),
- stop("'type' must be either 'import' or 'export'!"))
+ export = c("ZIEexport", "ZIE") )
return(obj)
}
-"print.ZIE" <-
-function(x, ...) {
+"print.ZIE" <- function(x, ...) {
Subclass <- class(x)[1]
cat("A", getTemp("ZIname"), "Import/Export definition object of subclass:", SubClass, "\n")
cat("\n", x$description, "\n\n")
@@ -809,9 +810,6 @@
"readExifRaw" <- function(rawfile, full = FALSE, check = TRUE) {
# Make sure dc_raw is available and rawfile exists
- if (check) {
- checkCapable( "dc_raw" )
- }
checkFileExists( rawfile )
# {{{ Temporary change directory to the one where the file is located
@@ -859,7 +857,8 @@
"compareExif" <- function(Exif1, Exif2) {
dif <- character(0)
# Need same 'Camera', 'ISO_speed', 'Shutter', 'Aperture', 'Focal_Length'
- ### TODO: make it work for larger Exif dataset. Currently requires that the fields are restricted to strict equal data
+ ### TODO: make it work for larger Exif dataset. Currently requires that the
+ ### fields are restricted to strict equal data
if (length(Exif1) != length(Exif2)) {
dif <- "Not same size for both Exif data!"
} else {
@@ -874,7 +873,9 @@
# {{{ isTestFile
"isTestFile" <- function(File) {
# Determine if a given file is a test file (a file with first line being 'ZI1est' and with size < 1000)
- if (file.info(File)$size > 1000) return(FALSE)
+ if (file.info(File)$size > 1000) {
+ return(FALSE)
+ }
checkFirstLine( File, "ZItest", stop = FALSE )
}
# }}}
@@ -888,8 +889,7 @@
#' checkBF("test.tif")
"checkBF" <- function(BFfile) {
- if (!file.exists(BFfile))
- return(paste("Blank-field file '", BFfile, "' not found!", sep = ""))
+ checkFileExists( BFfile, "Blank-field file '%s' not found!")
# Is it a test file?
if (isTestFile(BFfile)) return(character(0)) # We behave like if the file was correct!
@@ -945,7 +945,7 @@
}
# }}}
-#{{{ calibrate
+# {{{ calibrate
#' calibrates
#' @examples
#' Setwd("g:/zooplankton/madagascar2macro")
@@ -1180,27 +1180,20 @@
DcRawArgs = "-v -c -4 -q 3 -t 0 -k 0",
fake = FALSE, replace = FALSE, check = TRUE) {
- # {{{ checks
- # {{{ Check if the output file already exists
+ # Check if the output file already exists
if (file.exists(OutputFile)) {
# If we want to replace existing file, delete it, otherwise, we are done
if (replace) unlink(OutputFile) else return(TRUE)
}
- # }}}
- # {{{ Check if RawFile exists
- if (!file.exists(RawFile)) {
- return( paste("'", RawFile, "' not found", sep = "") )
- }
- # }}}
- # }}}
+ # Check if RawFile exists
+ checkFileExists( RawFile )
- # {{{ Do a fake convert
+ # Do a fake convert
if (fake) { # Create a test file with just ZItest in it
cat("ZItest\n", file = OutputFile)
return(TRUE)
}
- # }}}
# {{{ Do the conversion using dc_raw
# {{{ check that the system is capable of doing the conversion
More information about the Zooimage-commits
mailing list