[Zooimage-commits] r189 - in pkg/zooimage: . R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Aug 24 14:02:59 CEST 2010
Author: phgrosjean
Date: 2010-08-24 14:02:59 +0200 (Tue, 24 Aug 2010)
New Revision: 189
Modified:
pkg/zooimage/NAMESPACE
pkg/zooimage/R/RealTime.R
pkg/zooimage/R/ZIClass.R
pkg/zooimage/R/ZIRes.R
pkg/zooimage/R/ZITrain.R
pkg/zooimage/R/gui.R
pkg/zooimage/R/misc.R
pkg/zooimage/R/utilities.R
pkg/zooimage/R/zid.R
pkg/zooimage/R/zie.R
pkg/zooimage/R/zim.R
pkg/zooimage/man/ZIClass.Rd
pkg/zooimage/man/ZIRes.Rd
pkg/zooimage/man/utilities.Rd
pkg/zooimage/man/zie.Rd
Log:
Latest version on 24/08/2010 - Many fine tunings and a new object class ZIConf
Modified: pkg/zooimage/NAMESPACE
===================================================================
--- pkg/zooimage/NAMESPACE 2010-04-14 17:18:41 UTC (rev 188)
+++ pkg/zooimage/NAMESPACE 2010-08-24 12:02:59 UTC (rev 189)
@@ -36,10 +36,6 @@
export(compile.zie)
export(compress.zid)
export(compress.zid.all)
-export(confu)
-export(confu.map)
-export(confusion.bar)
-export(confusion.tree)
export(create.zim)
export(createZis)
export(ecd)
@@ -85,20 +81,13 @@
export(make.zie)
export(make.zim)
export(make.ZIRecode.level)
-export(merge.ZITable)
export(modalAssistant)
export(nnet2)
export(noext)
export(optInOutDecimalSep)
export(parse.ini)
export(plotAbdBio)
-export(plot.ZITable)
-export(predict.lvq)
-export(predict.nnet2)
-export(predict.ZIClass)
export(prepare.ZITrain)
-export(print.ZIClass)
-export(print.ZIE)
export(processImg)
export(process.sample)
export(process.samples)
@@ -124,8 +113,7 @@
export(Spectrum)
export(Spectrum.sample)
export(startPgm)
-
-export(trim)
+export(trimstring)
export(uncompress.zid)
export(uncompress.zid.all)
export(underscore2space)
@@ -139,6 +127,7 @@
export(viewResults)
export(write.ZITrain)
export(ZIClass)
+export(ZIConf)
export(zid.extract)
export(ZIDlg)
export(ZIE)
@@ -152,6 +141,16 @@
export(zip.img.all)
export(zip.ZITrain)
+S3method(predict, nnet2)
+S3method(predict, lvq)
+S3method(print, ZIClass)
+S3method(predict, ZIClass)
+S3method(print, ZIConf)
+S3method(plot, ZIConf)
+S3method(print, ZIE)
+S3method(plot, ZITable)
+S3method(merge, ZITable)
+
# The following objects are NOT exported
# ZOOIMAGEENV (environment holding ZooImage data)
# backspaces
@@ -203,12 +202,6 @@
# list.zip
# misc(prog, args, ...)
# misc_dcraw(file, arguments, output)
- # mustallbe
- # mustallmatch
- # mustbe
- # mustbeString
- # mustcontain
- # mustmatch
# netpbm(prog, args, ...)
# netpbm_pgmhist(file, delete = TRUE)
# netpbm_ppmtopgm(ppm, pgm)
Modified: pkg/zooimage/R/RealTime.R
===================================================================
--- pkg/zooimage/R/RealTime.R 2010-04-14 17:18:41 UTC (rev 188)
+++ pkg/zooimage/R/RealTime.R 2010-08-24 12:02:59 UTC (rev 189)
@@ -823,7 +823,7 @@
if (length(pos) < 1) return(NULL)
str <- x[pos[1]]
res <- strsplit(str, "=")[[1]][2]
- res <- trim(res)
+ res <- trimstring(res)
if (isTRUE(as.numeric)) res <- as.numeric(res)
return(res)
}
Modified: pkg/zooimage/R/ZIClass.R
===================================================================
--- pkg/zooimage/R/ZIClass.R 2010-04-14 17:18:41 UTC (rev 188)
+++ pkg/zooimage/R/ZIClass.R 2010-08-24 12:02:59 UTC (rev 189)
@@ -15,9 +15,6 @@
# You should have received a copy of the GNU General Public License
# along with ZooImage. If not, see <http://www.gnu.org/licenses/>.
-# Version 1.2.0: check package loading, and add a 'package' attribute to ZIClass
-### TODO: allow for defining parameters and use a plugin mechanism
-
# Modifications in calculation of probabilities to accept variables selection v1.2-2
"ZIClass" <- function (df, algorithm = c("lda", "randomForest"),
package = c("MASS", "randomForest"), Formula = Class ~ logArea + Mean + StdDev +
@@ -86,11 +83,11 @@
algorithm <- attr(x, "algorithm")
classes <- attr(x, "classes")
lclasses <- levels(classes)
- predict <- attr(x, "predict")
+ predicted <- attr(x, "predict")
k <- attr(x, "k")
cat("A ZIClass object predicting for", length(lclasses), "classes:\n")
print(lclasses)
- Confu <- confu(classes, predict)
+ Confu <- ZIConf(classes, predicted)
mism <- 100 * (1 - (sum(diag(Confu)) / sum(Confu)))
# Change the number of digits to display
@@ -117,8 +114,10 @@
{
# Make sure we have correct objects
- mustbe(object, "ZIClass")
- mustbe(ZIDat , c("ZIDat", "data.frame"))
+ if (!inherits(object, "ZIClass"))
+ stop("'object' must be a 'ZIClass' object")
+ if (!inherits(ZIDat, c("ZIDat", "data.frame")))
+ stop("'ZIDat' must be a 'ZIDat' or 'data.frame' object")
# Possibly load a specific package for prediction
package <- attr(object, "package")
@@ -156,151 +155,6 @@
return(res)
}
-"confu" <- function (classes1, classes2, classes.predicted = FALSE)
-{
- if (is.factor(classes1) || is.factor(classes2)) {
- if (NROW(classes1) != NROW(classes2))
- stop("Not same number of items in classes1 and classes2")
-
- # Check that levels match
- mustmatch(levels(classes1), levels(classes2),
- msg = "'Class' levels in the two objects do not match")
- clCompa <- data.frame(Class.x = classes1, Class.y = classes2)
- } else { # Merge two data frame according to common objects in "Id" column
-
- # Check levels match
- mustmatch(levels(classes1$Class), levels(classes2$Class),
- msg = "Levels for 'Class' in the two objects do not match")
-
- # Are there common objects left?
- clCompa <- merge(classes1, classes2, by = "Id")
- if (nrow(clCompa) == 0)
- stop("No common objects between the two 'classes' objects")
- }
-
- # How many common objects by level?
- NbPerClass <- table(clCompa$Class.x)
-
- # Confusion matrix
- if (classes.predicted) {
- Conf <- table(classes = clCompa$Class.x, predicted = clCompa$Class.y)
- } else {
- Conf <- table(Class1 = clCompa$Class.x, Class2 = clCompa$Class.y)
- }
-
- # Pourcent of common objects
- Acc <- sum(diag(Conf)) / sum(Conf) * 100
-
- # Change labels to get a more compact presentation
- colnames(Conf) <- formatC(1:ncol(Conf), digits = 1, flag = "0")
- rownames(Conf) <- paste(colnames(Conf), rownames(Conf))
-
- # Results
- attr(Conf, "accuracy") <- Acc
- attr(Conf, "nbr.per.class") <- NbPerClass
- return(Conf)
-}
-
-"confu.map" <- function (set1, set2, level = 1)
-{
- opar <- par(no.readonly = TRUE)
- on.exit(par(opar))
- par(mar = c(5, 12, 4, 2) + 0.1)
-
- n <- length(levels(set1))
- image(1:n, 1:n, 1 / (t(confu(set1, set2)[n:1, 1:n])), col = heat.colors(10),
- xlab = "", ylab = "", xaxt = "n", yaxt = "n")
- axis(1, at = 1:n, las = 2)
- axis(2, at = n:1, labels = paste(levels(set1), 1:n), las = 1)
- abline(h = (1:(n + 1)) - 0.5, lty = 2, col = "gray")
- abline(v = (1:(n + 1)) - 0.5, lty = 2, col = "gray")
-}
-
-# New function v1.2-2 using library gplots
-"confusion.tree" <- function (confmat, maxval, margin = NULL, Rowv = TRUE,
-Colv = TRUE)
-{
- nX <- nrow(confmat)
- nY <- ncol(confmat)
- nZ <- nX * nY
- confmat <- pmin(confmat, maxval)
-
- # Note: done in NAMESPACE
- # require(RColorBrewer)
- # require(gplots)
- mypalette <- brewer.pal(maxval - 1, "Spectral")
- heatmap.2(confmat, col= c(0, mypalette), symm = TRUE, margin = margin,
- trace = "both", Rowv = Rowv, Colv = Colv, cexRow = 0.2 + 1 / log10(nX),
- cexCol = 0.2 + 1 / log10(nY), tracecol = "Black", linecol = FALSE)
-}
-
-# New function v 1.2-2 false positive and negative
-"confusion.bar" <- function (confmat, mar = NULL)
-{
- if (!inherits(confmat, c("table", "matrix")))
- stop("'confmat' must be a table or a matrix")
- TP <- tp <- diag(confmat)
- fn <- rowSums(confmat) - tp
- fp <- colSums(confmat) - tp
- # Express fn and fp in proportions
- FN <- fn <- fn / (fn + tp)
- FP <- fp <- fp / (tp + fp)
- FP[is.na(FP)] <- 1
- # Rescale values so that:
- # fn/tp ratio and tp/fp ratio are kept, using same tp
- # total fn + tp + fp makes 100
- fp <- tp / (1 - fp) * fp
- # Rescale all so that they sum to 1
- scale <- fn + tp + fp
- fn <- fn / scale * 100
- tp <- tp / scale * 100
- fp <- fp / scale * 100
- # Just in case we have no tp at all:
- fn[is.na(tp)] <- 50
- fp[is.na(tp)] <- 50
- tp[is.na(tp)] <- 0
- res <- matrix(c(fp, tp, fn), ncol = 3)
- colnames(res) <- c( "fp", "tp", "fn")
- # Order items from smallest to largest tp
- pos <- order(res[, 2], decreasing = TRUE)
- res <- res[pos, ]
- FN <- FN[pos]
- FP <- FP[pos]
- TP <- TP[pos]
-
- # Plot
- if (is.null(mar)) mar <- c(1.1, 8.1, 4.1, 2.1)
- omar <- par("mar")
- on.exit(par(omar)) # mar = margin size c(bottom, left, top, right)
- par(mar = mar)
- barplot(t(res), horiz = TRUE, col = c("PeachPuff2", "green3", "lemonChiffon2"),
- xaxt = "n", las = 1, space = 0)
- abline(v = (1:9) * 10, lty = 2)
- abline(v = 50, lwd = 2)
-
- # Print the fraction of fp and fn
- text(rep(4, length(FP)), 1:length(FP) - 0.1,
- paste(round((1 - FP) * 100), "%", sep = ""),
- adj = c(1, 1), cex = 0.7)
- text(rep(99, length(FN)), 1:length(FN) - 0.1,
- paste(round((1 - FN) * 100), "%", sep = ""),
- adj = c(1, 1), cex = 0.7)
-
- # Print the number of true positives
- xpos <- res[, 1] + res[, 2] / 2
- text(xpos, 1:length(FN) - 0.1, round(TP),
- adj = c(0.5, 1), cex = 0.7)
-
- # Add a legend
- legend(50, length(FN) * 1.05, legend = c("false positive (FP)",
- "true positive (TP)", "false negative (FN)"),
- xjust = 0.5, yjust = 1, fill = c("PeachPuff2", "green3", "lemonChiffon2"),
- bty = "n", horiz = TRUE)
- axis(2, 1:length(FN) - 0.5, tick = FALSE, las = 1, cex.axis = 0.7,
- labels = names(attr(confmat, "nbr.per.class")))
- title(main = "Precision tp/(tp+fp) at left versus recall tp/(tp+fn) at right")
-}
-
"nnet2" <- function (formula, data, size = 7, rang = 0.1, decay = 5e-4,
maxit = 1000, ...)
{
@@ -317,7 +171,8 @@
{
# Note: done in NAMESPACE
# require(nnet)
- mustbe(object, "nnet2")
+ if (!inherits(object, "nnet2"))
+ stop("'object' must be a 'nnet2' object")
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
@@ -348,7 +203,8 @@
{
# Note: done in NAMESPACE
# require(class)
- mustbe(object, "lvq")
+ if (!inherits(object, "lvq"))
+ stop("'object' must be a 'lvq' object")
if (missing(newdata)) newdata <- object$data
lvqtest(object$codebook, newdata[, object$vars[-1]])
}
@@ -357,7 +213,8 @@
FormVarsSelect <- function (x)
{
# x must be a ZItrain object
- mustbe(x, "ZI1Train")
+ if (!inherits(x, "ZITrain"))
+ stop("'x' must be a 'ZITrain' object")
# Parameters measured on particles and new variables calculated
mes <- as.vector(colnames(calc.vars(x)))
Modified: pkg/zooimage/R/ZIRes.R
===================================================================
--- pkg/zooimage/R/ZIRes.R 2010-04-14 17:18:41 UTC (rev 188)
+++ pkg/zooimage/R/ZIRes.R 2010-08-24 12:02:59 UTC (rev 189)
@@ -25,7 +25,8 @@
checkFileExists(ZidFile)
# Check if ZIClass is of the right class
- mustbe(ZIClass, "ZIClass")
+ if (!inherits(ZIClass, "ZIClass"))
+ stop("'ZIClass' must be a 'ZIClass' object")
# Get ZIDat from the ZidFile
ZIDat <- read.zid(ZidFile)
@@ -113,7 +114,8 @@
} else { # Check that all zid files have entries in ZIDesc
Samples <- get.sampleinfo(ZidFiles, type = "sample",
ext = extensionPattern(".zid"))
- mustcontain(ZIDesc$Label, Samples, "One or more samples not in ZIDesc!")
+ if (!all(Samples %in% ZIDesc$Label))
+ stop("One or more samples not in 'ZIDesc'!")
}
# Start the process
@@ -209,8 +211,10 @@
breaks = seq(0.25, 2, by = 0.1), use.Dil = TRUE)
{
# Check arguments
- mustbe(ZIDat, "ZIDat")
- mustbeString(sample, 1)
+ if (!inherits(ZIDat, "ZIDat"))
+ stop("'ZIDat' must be a 'ZIDat' object")
+ if (!is.character(sample) || length(sample) != 1)
+ stop("'sample' must be a single character string")
# Extract only data for a given sample
# Sample is everything before a '+' sign
@@ -233,8 +237,10 @@
{
if (!isTRUE(RealT)) {
# Check arguments
- mustbe(ZIDat, "ZIDat")
- mustbeString(image, 1)
+ if (!inherits(ZIDat, "ZIDat"))
+ stop("'ZIDat' must be a 'ZIDat' object")
+ if (!is.character(image) || length(image) != 1)
+ stop("'image' must be a single character string")
# Select the image
dat <- ZIDat[ZIDat$Label == image, ]
@@ -246,7 +252,8 @@
# Taxa must correspond to levels in ZIDat$Ident
if (!is.null(taxa)) {
- mustcontain( levels(dat$Ident), taxa, "taxa not in ZIDat")
+ if (!all(taxa %in% levels(dat$Ident)))
+ stop("taxa not in 'ZIDat'")
dat <- dat[dat$Ident %in% taxa, ] # Select taxa
}
if (is.null(groups)) {
@@ -254,7 +261,8 @@
groups <- list("")
names(groups) <- "total"
}
- mustbe(groups, "list")
+ if (!inherits(groups, "list"))
+ stop("'groups' must be a 'list' object")
res <- lapply(groups, function (g) {
if (length(g) == 1 && g == "") { # Total abundance
@@ -275,9 +283,8 @@
# ZIDat is a table with VIS measurements and automatic Ident
# taxa must correspond to levels in ZIDat$Ident
if (!is.null(taxa)) {
- mustcontain(levels(ZIDat$Ident), taxa, "taxa not in ZIDat")
- # if (!all(taxa %in% levels(ZIDat$Ident)))
- # stop("taxa not in ZIDat")
+ if (!all(taxa %in% levels(dat$Ident)))
+ stop("taxa not in 'ZIDat'")
Dat <- ZIDat[ZIDat$Ident %in% taxa, ] # Select taxa
}
if (is.null(groups)) {
@@ -285,7 +292,8 @@
groups <- list("")
names(groups) <- "total"
}
- mustbe(groups, "list")
+ if (!inherits(groups, "list"))
+ stop("'groups' must be a 'list' object")
res <- lapply( groups, function (g) {
if (length(g) == 1 && g == "") { # Total abundance
@@ -322,8 +330,10 @@
{
if (!isTRUE(RealT)) {
# Check arguments
- mustbe(ZIDat, "ZIDat")
- mustbeString(sample, 1)
+ if (!inherits(ZIDat, "ZIDat"))
+ stop("'ZIDat' must be a 'ZIDat' object")
+ if (!is.character(sample) || length(sample) != 1)
+ stop("'sample' must be a single character string")
# Extract only data for a given sample
Smps <- getSample(ZIDat$Label, unique = TRUE, must.have = sample)
@@ -331,7 +341,8 @@
# Subsample, depending on taxa we keep
if (!is.null(taxa)) {
- mustcontain(levels(Smp$Ident), taxa, "taxa not in the sample")
+ 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)
@@ -399,7 +410,8 @@
res <- sum(Smp$Biomass)
names(res) <- header
} else {
- mustbe(groups, "list")
+ if (!inherits(groups, "list"))
+ stop("'groups' must be a 'list' object")
res <- if (length(groups) == 1 && groups=="") {
sum(Smp$Biomass)
} else {
@@ -413,7 +425,8 @@
# Subsample, depending on taxa we keep
Smp <- ZIDat
if (!is.null(taxa)) {
- mustcontain(levels(Smp$Ident), taxa, "taxa not in the sample")
+ 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)
@@ -487,7 +500,8 @@
res[i] <- sum(Smp$Biomass[Smp$Ident %in% grps[i]])
names(res) <- grps
} else {
- mustbe(groups, "list")
+ if (!inherits(groups, "list"))
+ stop("'groups' must be a 'list' object")
res <- if (length(groups) == 1 && groups=="") {
sum(Smp$Biomass)
} else {
@@ -504,8 +518,10 @@
type = c("absolute", "log", "relative"), header = "Abd")
{
# Check arguments
- mustbe(ZIDat, "ZIDat")
- mustbeString(sample, 1)
+ if (!inherits(ZIDat, "ZIDat"))
+ stop("'ZIDat' must be a 'ZIDat' object")
+ if (!is.character(sample) || length(sample) != 1)
+ stop("'sample' must be a single character string")
type <- match.arg(type, several.ok = FALSE)
# Extract only data for a given sample
@@ -538,7 +554,8 @@
res <- sum(Smp$Coef)
names(res) <- header
} else {
- mustbe(groups, "list")
+ if (!inherits(groups, "list"))
+ stop("'groups' must be a 'list' object")
res <- if (length(groups) == 1 && groups == "") {
sum(Smp$Coef)
} else {
@@ -556,12 +573,23 @@
"merge.ZITable" <- function (x, y, ...)
{
- data <- list( x, y, ... )
- mustallbe(.list = data, class = "ZITable",
- msg = "objects must all be ZITable objects")
- mustallmatch(.list = lapply(data, attr, "breaks"),
+ data <- list(x, y, ...)
+ lapply(data, function (x) {
+ if (!inherits(x, "ZITable")) stop("arguments must all be 'ZITable' objects")
+ })
+
+ mustallmatch <- function (.list, msg = "all must match") {
+ n <- length(.list)
+ if (n < 2) stop("need at list 2 elements")
+ first <- .list[[1]]
+ for (i in 2:n)
+ if (!all(sort(first) == sort(.list[[i]]))) stop(msg)
+ return()
+ }
+
+ mustallmatch(lapply(data, attr, "breaks"),
msg = "breaks of all objects must match")
- mustallmatch(.list = lapply( data, attr, "unit"),
+ mustallmatch(lapply( data, attr, "unit"),
msg = "units of all objects must match")
Reduce("+", data)
}
Modified: pkg/zooimage/R/ZITrain.R
===================================================================
--- pkg/zooimage/R/ZITrain.R 2010-04-14 17:18:41 UTC (rev 188)
+++ pkg/zooimage/R/ZITrain.R 2010-08-24 12:02:59 UTC (rev 189)
@@ -193,12 +193,14 @@
"recode.ZITrain" <- function (ZITrain, ZIRecode, warn.only = FALSE)
{
# Check classes
- mustbe(ZITrain, "ZITrain")
- mustbe(ZIRecode, "ZIRecode")
+ if (!inherits(ZITrain, "ZITrain"))
+ stop("'ZITrain' must be a 'ZITrain' object")
+ if (!inherits(ZIRecode, "ZIRecode"))
+ stop("'ZIRecode' must be a 'ZIRecode' object")
# Check that all levels in ZITrain$Class are represented in ZIRecode
- mustmatch(levels(ZITrain$Class), ZIRecode[ , 1],
- msg = "Not all levels of ZIRecode match levels of ZITrain")
+ if (!all(sort(levels(ZITrain$Class)) == sort(levels(ZIRecode[ , 1]))))
+ stop("Not all levels of ZIRecode match levels of ZITrain")
# Class column of ZITrain is transformed into a character vector
Class <- as.character(ZITrain$Class)
@@ -220,7 +222,8 @@
"make.ZIRecode.level" <- function (ZITrain, level = 1)
{
# Check class
- mustbe(ZITrain, "ZITrain")
+ if (!inherits(ZITrain, "ZITrain"))
+ stop("'ZITrain' must be a 'ZITrain' object")
# Get the "path" attribute
Path <- attr(ZITrain, "path")
Modified: pkg/zooimage/R/gui.R
===================================================================
--- pkg/zooimage/R/gui.R 2010-04-14 17:18:41 UTC (rev 188)
+++ pkg/zooimage/R/gui.R 2010-08-24 12:02:59 UTC (rev 189)
@@ -704,8 +704,8 @@
# Analyze a classifier, using a ZI1Class object (new version)
# Ask for an option of analysis
defval <- "Confusion matrix"
- opts <- c("Confusion matrix", "Confusion matrix reworked",
- "False positive and negative")
+ opts <- c("Print", "Plot (simple)", "Plot (with tree)",
+ "Precision/recall")
# Then, show the dialog box
res <- modalAssistant(paste(getTemp("ZIClass"), "Analyze a classifier"),
c("This is a simplified version of the analysis of classifiers",
@@ -721,15 +721,13 @@
warn.only = FALSE)
if (is.null(ZIC)) stop("No current classifier. Please, make one first!")
ZIC <- get(ZIC, envir = .GlobalEnv)
- classes <- attr(ZIC, "classes")
- predicted <- attr(ZIC, "kfold.predict")
- conf <- confu(classes, predicted, classes.predicted = TRUE)
- print(conf)
- if (res == "Confusion matrix") confu.map(classes, predicted)
- if (res == "Confusion matrix reworked") confusion.tree(conf, maxval = 10,
- margin = c(2,10), Rowv = TRUE, Colv = TRUE)
- if (res == "False positive and negative") confusion.bar(conf)
- #return(invisible(res))
+ conf <- ZIConf(ZIC)
+ switch(res,
+ `Print` = print(conf),
+ `Plot (simple)` = plot(conf, type = "image"),
+ `Plot (with tree)` = plot(conf, type = "tree_image"),
+ `Precision/recall` = plot(conf, type = "precision_recall"))
+ return(invisible(res))
}
# Edit a samples description file... or create a new one!
Modified: pkg/zooimage/R/misc.R
===================================================================
--- pkg/zooimage/R/misc.R 2010-04-14 17:18:41 UTC (rev 188)
+++ pkg/zooimage/R/misc.R 2010-08-24 12:02:59 UTC (rev 189)
@@ -175,65 +175,6 @@
out[file.info(file.path(dir, basename(out)))$isdir]
}
-# Must utilities
-"mustbe" <- function (x, class, msg)
-{
- if (!any(sapply(class, function (cl) inherits(x, cl))))
- if (length(class) == 1) {
- 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("'%s' must be of one of these classes: ",
- deparse(substitute(x)), paste(class, collapse = ", "), sep = "")
- stop(msg)
- }
-}
-
-"mustallbe" <- function (..., .list = list(...), class, msg)
- return(invisible(lapply(.list, mustbe, class = class, msg = msg)))
-
-"mustmatch" <- function (x, y, msg)
-{
- if (!all(sort(x) == sort(y))) {
- if (missing(msg)) msg <- sprintf("'%s' and '%s' must match",
- deparse(substitute(x)), deparse(substitute(y)))
- stop(msg)
- }
- return(invisible(NULL))
-}
-
-"mustallmatch" <- function (..., .list = list(...), msg = "all must match")
-{
- n <- length(.list)
- if (n==0 || n == 1) stop("need at list 2 elements")
- first <- .list[[1]]
- for (i in 2:n)
- mustmatch(first, .list[[i]], msg = msg)
- return(invisible(NULL))
-}
-
-"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))
-}
-
# Get a template file from the "ZITemplate" option
"template" <- function (file = "default.zim", dir = getOption("ZITemplates"))
{
Modified: pkg/zooimage/R/utilities.R
===================================================================
--- pkg/zooimage/R/utilities.R 2010-04-14 17:18:41 UTC (rev 188)
+++ pkg/zooimage/R/utilities.R 2010-08-24 12:02:59 UTC (rev 189)
@@ -123,19 +123,6 @@
RData = c("R data" , ".RData" ))
filters <- matrix(filters, ncol = 2, byrow = TRUE)
res <- tk_choose.files(caption = title, multi = multi, filters = filters)
- #} else { # Old treatment using Windows-only function
- # filters <- switch(type,
- # ZipZid = c("ZooImage files (*.zip;*.zid)" , "*.zip;*.zid"),
- # ZimZis = c("ZooImage metadata files (*.zim;*.zis)" , "*.zim;*.zis"),
- # Zip = c("ZooImage picture files (*.zip)" , "*.zip" ),
- # Zid = c("ZooImage data files (*.zid)" , "*.zid" ),
- # Zim = c("ZooImage metadata files (*.zim)" , "*.zim" ),
- # Zis = c("ZooImage sample files (*.zis)" , "*.zis" ),
- # Zie = c("ZooImage extension files (*.zie)" , "*.zie" ))
- # filters <- matrix(filters, ncol = 2, byrow = TRUE)
- # res <- choose.files(caption = title, multi = multi, filters = filters)
- #}
-
if (length(res) && res != "" && quote)
res <- paste('"', res, '"', sep = "")
return(res)
@@ -176,7 +163,7 @@
return(gsub("_", " ", char))
# Trim leading and trailing white spaces and tabs
-"trim" <- function (char)
+"trimstring" <- function (char)
return(sub("\\s+$", "", sub("^\\s+", "", char)))
# Get the name of a file, without its extension
@@ -262,7 +249,8 @@
# All sample with at least one entry in a given object
"list.samples" <- function (obj)
{
- mustbe(obj, c("ZIDat", "ZIDesc","ZITrain"))
+ if (!inherits(obj, c("ZIDat", "ZIDesc","ZITrain")))
+ stop("'obj' must be a 'ZIDat', 'ZIDesc', or 'ZITrain' object")
# List all samples represented in a given object
if (inherits(obj, "ZIDat")) {
@@ -289,11 +277,11 @@
# is str a section
is.section <- function (str)
- as.logical(length(grep("^\\[.+\\]$", trim(str)) > 0))
+ as.logical(length(grep("^\\[.+\\]$", trimstring(str)) > 0))
# Get the name of a section
get.section.name <- function (str)
- sub("^\\[", "", sub("\\]$", "", trim(str)))
+ sub("^\\[", "", sub("\\]$", "", trimstring(str)))
# Transform a vector of characters into a data frame,
# possibly with type conversion
@@ -304,7 +292,7 @@
return(character(0))
# Trim leading and trailing white spaces
- data <- trim(data)
+ data <- trimstring(data)
# Convert underscore to space
data <- underscore2space(data)
@@ -327,8 +315,8 @@
# Make sure we have a section for the first entries (otherwise, use [.])
if (!is.section(data[1, 1]))
data <- rbind(c("[.]", "[.]"), data)
- Names <- as.vector(trim(data[, 1]))
- Dat <- as.vector(trim(data[, 2]))
+ Names <- as.vector(trimstring(data[, 1]))
+ Dat <- as.vector(trimstring(data[, 2]))
# Determine which is a section header
Sec <- grep("\\[.+\\]$", Names)
@@ -365,14 +353,13 @@
# Merge two lists of data frames
"list.merge" <- function (x, y)
{
- mustallbe(x, y, class = "list")
-
+ if (!inherits(x, "list") || !inherits(y, "list"))
+ stop("'x' and 'y' must both be 'list' objects")
xitems <- names(x)
yitems <- names(y)
xandy <- xitems[xitems %in% yitems]
xonly <- xitems[!(xitems %in% xandy)]
yonly <- yitems[!(yitems %in% xandy)]
-
# First merge common items
if (length(xandy) > 0) {
res <- lapply(xandy, function (item) {
@@ -382,25 +369,11 @@
} else {
res <- list()
}
-
if (length(xonly) > 0) res[xonly] <- x[xonly]
if (length(yonly) > 0) res[yonly] <- y[yonly]
return(res)
}
-"combine" <- function (..., .list = list(...))
-{
- force(.list)
- mergefun <- function (x, y) {
- if (all(sort(names(x)) == sort(names(y)))) {
- rbind(x, y)
- } else {
- merge(x, y, all = TRUE)
- }
- }
- Reduce(mergefun, .list)
-}
-
# Add items across two lists (names must be the same)
"list.add" <- function (..., .list = list(...))
list.reduce(.list= .list, FUN = "+")
Modified: pkg/zooimage/R/zid.R
===================================================================
--- pkg/zooimage/R/zid.R 2010-04-14 17:18:41 UTC (rev 188)
+++ pkg/zooimage/R/zid.R 2010-08-24 12:02:59 UTC (rev 189)
@@ -20,7 +20,7 @@
# type: must be ZI1
# check.vignettes: do we check vignettes as well
# show.log: do we show a log at the end
-verify.zid <- function (zidir, type = "ZI1", check.vignettes = TRUE,
+"verify.zid" <- function (zidir, type = "ZI1", check.vignettes = TRUE,
show.log = TRUE)
{
# Check the format of the file
@@ -167,7 +167,7 @@
}
# Trim leading and trailing spaces in Lines
- Lines <- trim(Lines)
+ Lines <- trimstring(Lines)
# Convert underscore to space
Lines <- underscore2space(Lines)
@@ -222,8 +222,20 @@
results <- Filter(notnull.filter , results)
list.allmeta <- Filter(notnull.filter, lapply(results, "[[", "meta"))
list.allmes <- Filter(notnull.filter, lapply(results, "[[", "mes"))
- allmeta <- combine(.list = list.allmeta)
- allmes <- combine(.list = list.allmes)
+
+ combine <- function (.list) {
+ force(.list)
+ mergefun <- function (x, y) {
+ if (all(sort(names(x)) == sort(names(y)))) {
+ rbind(x, y)
+ } else {
+ merge(x, y, all = TRUE)
+ }
+ }
+ Reduce(mergefun, .list)
+ }
+ allmeta <- combine(list.allmeta)
+ allmes <- combine(list.allmes)
rownames(allmes) <- 1:nrow(allmes)
# Calculate an ECD from Area if there is not one yet
Modified: pkg/zooimage/R/zie.R
===================================================================
--- pkg/zooimage/R/zie.R 2010-04-14 17:18:41 UTC (rev 188)
+++ pkg/zooimage/R/zie.R 2010-08-24 12:02:59 UTC (rev 189)
@@ -283,7 +283,7 @@
### processed!)
Progress(i, nLines)
if (!grepl("^[-][>]", Lines[i])) { # This is not a state change command
- File <- MakeImageName(trim(sub("[=].*$", "", Lines[i])))
+ File <- MakeImageName(trimstring(sub("[=].*$", "", Lines[i])))
checkFileExists(File)
if (File %in% allImages)
stop(sprintf("Duplicated use of the same file : '%s' !", File))
@@ -412,7 +412,7 @@
Key <- sub("^[-][>]([^ =]+).*$", "\\1", dat)
# Special treatment if Key == "Sample"
if (Key == "Sample") {
- attr(zimData, "Sample") <- trim(sub("^[^=]+=", "", dat))
+ attr(zimData, "Sample") <- trimstring(sub("^[^=]+=", "", dat))
# Indicate that we process another sample
attr(zimData, "MakeZim") <- TRUE # Tell to make the zim file
attr(zimData, "Exif") <- ""
@@ -461,7 +461,7 @@
# This is not a state change command
if (length(res) == 1 && res == FALSE) {
- File <- MakeImageName(trim(sub("[=].*$", "", Lines[i])))
+ File <- MakeImageName(trimstring(sub("[=].*$", "", Lines[i])))
# Determine the name of the converted file
if (Convert != "") {
@@ -480,7 +480,7 @@
# and check if it is a calibration file
FileConvExt <- tolower(sub("^.*[.]", "", FileConv))
# Calculate the final name we want for the converted file
- NewFile <- trim(sub("^.*[=]", "", Lines[i]))
+ NewFile <- trimstring(sub("^.*[=]", "", Lines[i]))
# 1) If this is 'key' or 'key=' (NeWFile == ""), then,
# the file is not renamed!
if (NewFile == "") {
Modified: pkg/zooimage/R/zim.R
===================================================================
--- pkg/zooimage/R/zim.R 2010-04-14 17:18:41 UTC (rev 188)
+++ pkg/zooimage/R/zim.R 2010-08-24 12:02:59 UTC (rev 189)
@@ -137,7 +137,7 @@
if (length(Lines) < 1) stop("File is empty!")
# Trim leading and trailing white spaces
- Lines <- trim(Lines)
+ Lines <- trimstring(Lines)
# Check that all required fields are present for a simple .zim file
misfields <- reqfields[!(reqfields %in% Lines)]
@@ -156,7 +156,7 @@
posHeaders <- grep("^\\[Data\\]$", Lines)[1] + 1
LineHeader <- scan(zimfile, character(), sep = "%", skip = posHeaders,
nmax = 1, flush = TRUE, quiet = TRUE, comment.char = "=")
- Headers <- trim(strsplit(LineHeader, "\t")[[1]])
+ Headers <- trimstring(strsplit(LineHeader, "\t")[[1]])
misHeaders <- reqcols[!(reqcols %in% Headers)]
if (length(misHeaders) > 0)
stop(paste("Missing columns in the table:", paste(misHeaders,
Modified: pkg/zooimage/man/ZIClass.Rd
===================================================================
--- pkg/zooimage/man/ZIClass.Rd 2010-04-14 17:18:41 UTC (rev 188)
+++ pkg/zooimage/man/ZIClass.Rd 2010-08-24 12:02:59 UTC (rev 189)
@@ -1,7 +1,6 @@
\name{ZIClass}
\alias{ZIClass}
\alias{predict.ZIClass}
-\alias{confu}
\title{ Create and manipulate 'ZIClass' objects }
\description{
@@ -17,9 +16,8 @@
Max + logPerim. + logMajor + logMinor + Circ. + logFeret + IntDen +
Elongation + CentBoxD + GrayCentBoxD + CentroidsD + Range + MeanPos +
SDNorm + CV, calc.vars = "calc.vars", k.xval = 10, \dots)
-predict.ZIClass(object, ZIDat, calc.vars = TRUE, class.only = FALSE,
+\method{predict}{ZIClass}(object, ZIDat, calc.vars = TRUE, class.only = FALSE,
type = "class", na.rm = FALSE, \dots)
-confu(classes1, classes2, classes.predicted = FALSE)
}
\arguments{
@@ -35,10 +33,6 @@
\item{class.only}{ If TRUE, retrun just a vector with classification, otherwise, return a 'ZIDat' object with 'Ident' column appended to it }
\item{type}{ The type of result to return, \code{"class"} by default }
\item{na.rm}{ Do we eliminate entries with missing data first? }
- \item{classes1}{ One classification to compare }
- \item{classes2}{ A second classification to compare }
- \item{classes.predicted}{ Do we compare classes with predicted classes, or just two
- differnet classifications? }
}
\value{
@@ -63,5 +57,5 @@
\examples{
##TODO...
}
-\keyword{ tree }
+\keyword{tree}
Modified: pkg/zooimage/man/ZIRes.Rd
===================================================================
--- pkg/zooimage/man/ZIRes.Rd 2010-04-14 17:18:41 UTC (rev 188)
+++ pkg/zooimage/man/ZIRes.Rd 2010-08-24 12:02:59 UTC (rev 189)
@@ -18,8 +18,8 @@
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)
-merge.ZITable(x, y, ...)
-plot.ZITable(x, y, ...)
+\method{merge}{ZITable}(x, y, ...)
+\method{plot}{ZITable}(x, y, ...)
plotAbdBio(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",
Modified: pkg/zooimage/man/utilities.Rd
===================================================================
--- pkg/zooimage/man/utilities.Rd 2010-04-14 17:18:41 UTC (rev 188)
+++ pkg/zooimage/man/utilities.Rd 2010-08-24 12:02:59 UTC (rev 189)
@@ -1,7 +1,6 @@
\name{utilities}
\alias{calc.vars}
\alias{ClearProgress}
-\alias{combine}
\alias{ecd}
\alias{get.sampleinfo}
\alias{getKey}
@@ -20,7 +19,7 @@
\alias{selectFile}
\alias{setKey}
\alias{setwd}
-\alias{trim}
+\alias{trimstring}
\alias{underscore2space}
\alias{ZIpgm}
\alias{ZIpgmhelp}
@@ -35,7 +34,6 @@
list.merge(x, y)
list.add(\dots, .list = list(\dots))
list.reduce(\dots, .list = list(\dots), FUN = "+")
-combine(\dots, .list = list(\dots))
calc.vars(x)
ecd(area)
@@ -55,7 +53,7 @@
getDec()
noext(file)
-trim(char)
+trimstring(char)
underscore2space(char)
parse.ini(data, label = "1")
@@ -127,9 +125,9 @@
}
\value{
- The combined object is returned for \code{combine()}, \code{list.add()},
- \code{list.reduce()} and \code{list.merge}. \code{list.add()} is just a
- shortcut for \code{list.reduce(FUN = "+")}.
+ The combined object is returned for \code{list.add()}, \code{list.reduce()}
+ and \code{list.merge}. \code{list.add()} is just a shortcut for
+ \code{list.reduce(FUN = "+")}.
The data.frame with additional columns for calculated variables with
\code{calc.vars}
@@ -143,7 +141,7 @@
an empty string (\code{""}) is returned in case there is no corresponding
element found.
- Transformed strings for \code{noext()}, \code{trim()} and
+ Transformed strings for \code{noext()}, \code{trimstring()} and
\code{underscore2space()}
\code{parse.ini()} reads the data and creates a list of data frames. Each
@@ -186,7 +184,7 @@
\examples{
# Character strings and filenames manipulation functions
underscore2space("Some_string_to_convert")
-trim(" \tString with\textra spaces \t")
+trimstring(" \tString with\textra spaces \t")
noext(paste(tempfile(), ".ext", sep = ""))
# Given a correct ZooImage name for a sample, return parts of it
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/zooimage -r 189
More information about the Zooimage-commits
mailing list