[Zooimage-commits] r234 - in pkg: mlearning mlearning/R mlearning/man phytoimage/inst/etc zooimage zooimage/R zooimage/inst/etc zooimage/man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mon Aug 13 01:46:31 CEST 2012
Author: phgrosjean
Date: 2012-08-13 01:46:30 +0200 (Mon, 13 Aug 2012)
New Revision: 234
Removed:
pkg/zooimage/R/ZIMan.R
pkg/zooimage/man/ZIMan.Rd
Modified:
pkg/mlearning/NAMESPACE
pkg/mlearning/R/confusion.R
pkg/mlearning/R/mlearning.R
pkg/mlearning/man/confusion.Rd
pkg/mlearning/man/mlearning.Rd
pkg/phytoimage/inst/etc/Conversion.txt
pkg/zooimage/DESCRIPTION
pkg/zooimage/NAMESPACE
pkg/zooimage/R/ZIClass.R
pkg/zooimage/R/ZIRes.R
pkg/zooimage/R/ZITrain.R
pkg/zooimage/R/gui.R
pkg/zooimage/R/utilities.R
pkg/zooimage/inst/etc/Conversion.txt
pkg/zooimage/man/ZIClass.Rd
pkg/zooimage/man/ZIRes.Rd
pkg/zooimage/man/ZITrain.Rd
pkg/zooimage/man/gui.Rd
pkg/zooimage/man/utilities.Rd
Log:
svm added in mlearning. ZIres refactored ans ZIMan eliminated in zooimage
Modified: pkg/mlearning/NAMESPACE
===================================================================
--- pkg/mlearning/NAMESPACE 2012-08-10 14:09:22 UTC (rev 233)
+++ pkg/mlearning/NAMESPACE 2012-08-12 23:46:30 UTC (rev 234)
@@ -16,6 +16,7 @@
export(mlRforest)
export(mlLvq)
export(mlNnet)
+export(mlSvm)
export(mlNaiveBayes)
#export(mlNaiveBayesWeka)
@@ -62,6 +63,7 @@
S3method(mlRforest, default)
S3method(mlLvq, default)
S3method(mlNnet, default)
+S3method(mlSvm, default)
S3method(mlNaiveBayes, default)
#S3method(mlNaiveBayesWeka, default)
@@ -70,6 +72,7 @@
S3method(mlRforest, formula)
S3method(mlLvq, formula)
S3method(mlNnet, formula)
+S3method(mlSvm, formula)
S3method(mlNaiveBayes, formula)
#S3method(mlNaiveBayesWeka, formula)
@@ -77,3 +80,4 @@
S3method(predict, mlQda)
S3method(predict, mlRforest)
S3method(predict, mlLvq)
+S3method(predict, mlSvm)
Modified: pkg/mlearning/R/confusion.R
===================================================================
--- pkg/mlearning/R/confusion.R 2012-08-10 14:09:22 UTC (rev 233)
+++ pkg/mlearning/R/confusion.R 2012-08-12 23:46:30 UTC (rev 234)
@@ -2,9 +2,15 @@
UseMethod("confusion")
## TODO: implement weights
-.confusion <- function (classes, labels, prior, ...)
+.confusion <- function (classes, labels, useNA, prior, ...)
{
- res <- table(classes, dnn = labels)
+ ## useNA can be "no", "always" or "ifany", but with the later value
+ ## one takes the risk to get non square matrix if there are NAs in only
+ ## on vector of classes => change to "no" or "always", depending if there
+ ## are missing data or not
+ if (useNA == "ifany")
+ if (any(is.na(classes))) useNA <- "always" else useNA <- "no"
+ res <- table(classes, dnn = labels, useNA = useNA)
total <- sum(res)
truePos <- sum(diag(res))
row.freqs <- rowSums(res)
@@ -28,7 +34,7 @@
}
confusion.default <- function (x, y = NULL, vars = c("Actual", "Predicted"),
-labels = vars, merge.by = "Id", prior, ...)
+labels = vars, merge.by = "Id", useNA = "ifany", prior, ...)
{
## If the object is already a 'confusion' object, return it
if (inherits(x, "confusion")) {
@@ -122,14 +128,15 @@
## Construct the confusion object
if (missing(prior)) {
- .confusion(classes = clCompa, labels = labels, ...)
+ .confusion(classes = clCompa, labels = labels, useNA = useNA, ...)
} else {
- .confusion(classes = clCompa, labels = labels, prior = prior, ...)
+ .confusion(classes = clCompa, labels = labels, useNA = useNA,
+ prior = prior, ...)
}
}
confusion.mlearning <- function (x, y = response(x),
-labels = c("Actual", "Predicted"), prior, ...) {
+labels = c("Actual", "Predicted"), useNA = "ifany", prior, ...) {
## Check labels
labels <- as.character(labels)
if (length(labels) != 2)
@@ -153,10 +160,10 @@
## Construct the confusion object
if (missing(prior)) {
.confusion(data.frame(class1 = y, class2 = class2),
- labels = labels, ...)
+ labels = labels, useNA = useNA, ...)
} else {
.confusion(data.frame(class1 = y, class2 = class2),
- labels = labels, prior = prior, ...)
+ labels = labels, useNA = useNA, prior = prior, ...)
}
}
@@ -284,7 +291,6 @@
invisible(x)
}
-## TODO: a precision-recall diagram for all groups with F1-score lines
plot.confusion <- function (x, y = NULL,
type = c("image", "barplot", "stars", "dendrogram"), stat1 = "Recall",
stat2 = "Precision", names, ...)
@@ -342,7 +348,7 @@
## Recode row and column names for more compact display
colnames(x) <- names2 <- formatC(1:n, digits = 1, flag = "0")
- rownames(x) <- names1 <- paste(names2, rownames(x))
+ rownames(x) <- names1 <- paste(rownames(x), names2)
## Transform for better colorization
## (use a transfo to get 0, 1, 2, 3, 4, 7, 10, 15, 25+)
@@ -690,15 +696,23 @@
Fmicro <- 2 * meanRecall * meanPrecision / (meanRecall + meanPrecision)
Fmacro <- sum(Fscore, na.rm = TRUE) / Ngp
- res <- data.frame(
+ ## Take care to avoid missing data for data frame rownames!
+ nms <- names(Fscore)
+ nms[is.na(nms)] <- "<NA>"
+ names(Fscore) <- nms
+
+ ## Create a data frame with all results
+ res <- data.frame(
Fscore = Fscore, Recall = Recall, Precision = Precision,
Specificity = Specificity, NPV = NPV, FPR = FPR, FNR = FNR, FDR = FDR,
FOR = FOR, LRPT = LRPT, LRNT = LRNT, LRPS = LRPS, LRNS = LRNS,
BalAcc = BalAcc, MCC = MCC, Chisq = Chisq, Bray = Bray, Auto = TP_FP,
Manu = TP_FN, A_M = Auto_Manu, TP = TP, FP = FP, FN = FN, TN = TN)
- rownames(res) <- lev <- rownames(object)
-
+ lev <- rownames(object)
+ lev[is.na(lev)] <- "<NA>"
+ rownames(res) <- lev
+
## Sort the table in function of one parameter... by default Fscore
if (length(sort.by) && sort.by != FALSE) {
if (sort.by %in% names(res)) {
Modified: pkg/mlearning/R/mlearning.R
===================================================================
--- pkg/mlearning/R/mlearning.R 2012-08-10 14:09:22 UTC (rev 233)
+++ pkg/mlearning/R/mlearning.R 2012-08-12 23:46:30 UTC (rev 234)
@@ -975,6 +975,112 @@
.expandFactor(lvqtest(object, newdata), n, ndrop)
}
+## svm from e1071 package
+mlSvm <- function (...)
+ UseMethod("mlSvm")
+
+mlSvm.formula <- function(formula, data, scale = TRUE, type = NULL,
+kernel = "radial", classwt = NULL, ..., subset, na.action)
+ mlearning(formula, data = data, method = "mlSvm", model.args =
+ list(formula = formula, data = substitute(data),
+ subset = substitute(subset)), call = match.call(),
+ ..., subset = subset, na.action = substitute(na.action))
+
+mlSvm.default <- function (train, response, scale = TRUE, type = NULL,
+kernel = "radial", classwt = NULL, ...)
+{
+ dots <- list(...)
+ .args. <- dots$.args.
+ dots$.args. <- NULL
+ if (!length(.args.)) {
+ if (is.factor(response)) {
+ Type <- "classification"
+ } else Type <- "regression"
+ .args. <- list(levels = levels(response),
+ n = c(intial = NROW(train), final = NROW(train)),
+ type = Type, na.action = "na.pass",
+ mlearning.call = match.call(), method = "mlSvm")
+ }
+ dots$scale <- scale
+ dots$type <- type
+ dots$kernel <- kernel
+ dots$class.weigths <- classwt
+ #dots$probability <- TRUE
+
+ ## Return a mlearning object
+ structure(e1071:::svm.default(x = sapply(train, as.numeric), y = response,
+ scale = scale, type = type, kernel = kernel, class.weights = classwt,
+ probability = TRUE, ...), formula = .args.$formula, train = train,
+ response = response, levels = .args.$levels, n = .args.$n, args = dots,
+ optim = .args.$optim, numeric.only = TRUE, type = .args.$type,
+ pred.type = c(class = "class", membership = "raw"),
+ summary = "summary", na.action = .args.$na.action,
+ mlearning.call = .args.$mlearning.call, method = .args.$method,
+ algorithm = "support vector machine",
+ class = c("mlSvm", "mlearning", "svm"))
+}
+
+predict.mlSvm <- function(object, newdata,
+type = c("class", "membership", "both"), method = c("direct", "cv"),
+na.action = na.exclude, ...)
+{
+ if (!inherits(object, "mlSvm"))
+ stop("'object' must be a 'mlSvm' object")
+
+ ## If method == "cv", delegate to cvpredict()
+ method <- as.character(method)[1]
+ if (method == "cv") {
+ if (!missing(newdata))
+ stop("cannot handle new data with method = 'cv'")
+ return(cvpredict(object = object, type = type, ...))
+ }
+
+ ## Recalculate newdata according to formula...
+ if (missing(newdata)) { # Use train
+ newdata <- attr(object, "train")
+ } else if (attr(object, "optim")) { # Use optimized approach
+ ## Just keep vars similar as in train
+ vars <- names(attr(object, "train"))
+ if (!all(vars %in% names(newdata)))
+ stop("One or more missing variables in newdata")
+ newdata <- newdata[, vars]
+ } else { # Use model.frame
+ newdata <- model.frame(formula = attr(object, "formula"),
+ data = newdata, na.action = na.pass)[, names(attr(object, "train"))]
+ }
+ ## Only numerical predictors
+ newdata <- sapply(as.data.frame(newdata), as.numeric)
+
+ ## Determine how many data and perform na.action
+ n <- NROW(newdata)
+ newdata <- match.fun(na.action)(newdata)
+ ndrop <- attr(newdata, "na.action")
+ attr(newdata, "na.action") <- NULL
+
+ ## Delegate to the e1071 predict.svm method
+ if (as.character(type)[1] == "class") proba <- FALSE else proba <- TRUE
+ class(object) <- class(object)[-(1:2)]
+ if (attr(object, "type") == "regression")
+ return(predict(object, newdata = newdata, ...))
+
+ ## This is for classification
+ res <- predict(object, newdata = newdata,
+ probability = proba, ...)
+ proba <- attr(res, "probabilities")
+
+ ## Rework results according to what we want
+ switch(as.character(type)[1],
+ class = .expandFactor(factor(as.character(res), levels = levels(object)),
+ n, ndrop),
+ membership = .expandMatrix(.membership(proba, levels = levels(object)),
+ n, ndrop),
+ both = list(class = .expandFactor(factor(as.character(res),
+ levels = levels(object)), n, ndrop),
+ membership = .expandMatrix(.membership(proba, levels = levels(object)),
+ n, ndrop)),
+ stop("unrecognized 'type' (must be 'class', 'membership' or 'both')"))
+}
+
## NaiveBayes from e1071 package
mlNaiveBayes <- function (...)
UseMethod("mlNaiveBayes")
Modified: pkg/mlearning/man/confusion.Rd
===================================================================
--- pkg/mlearning/man/confusion.Rd 2012-08-10 14:09:22 UTC (rev 233)
+++ pkg/mlearning/man/confusion.Rd 2012-08-12 23:46:30 UTC (rev 234)
@@ -26,9 +26,9 @@
\usage{
confusion(x, \dots)
\method{confusion}{default}(x, y = NULL, vars = c("Actual", "Predicted"),
- labels = vars, merge.by = "Id", prior, \dots)
+ labels = vars, merge.by = "Id", useNA = "ifany", prior, \dots)
\method{confusion}{mlearning}(x, y = response(x),
- labels = c("Actual", "Predicted"), prior, \dots)
+ labels = c("Actual", "Predicted"), useNA = "ifany", prior, \dots)
\method{print}{confusion}(x, sums = TRUE, error.col = sums, digits = 0,
sort = "ward", \dots)
@@ -68,6 +68,9 @@
the same as \code{vars} or the one in the confusion matrix. }
\item{merge.by}{ a character string with the name of variables to use to merge
the two data frames, or \code{NULL}. }
+ \item{useNA}{ do we keep NAs as a separate category? The default \code{"ifany"}
+ creates this category only if there are missing values. Other possibilities
+ are \code{"no"}, or \code{"always"}. }
\item{prior}{ class frequencies to use for first classifier that
is tabulated in the rows of the confusion matrix. For its value, see here
under, the \code{value} argument. }
Modified: pkg/mlearning/man/mlearning.Rd
===================================================================
--- pkg/mlearning/man/mlearning.Rd 2012-08-10 14:09:22 UTC (rev 233)
+++ pkg/mlearning/man/mlearning.Rd 2012-08-12 23:46:30 UTC (rev 234)
@@ -28,6 +28,10 @@
\alias{mlLvq.default}
\alias{mlLvq.formula}
\alias{predict.mlLvq}
+\alias{mlSvm}
+\alias{mlSvm.default}
+\alias{mlSvm.formula}
+\alias{predict.mlSvm}
\alias{mlNaiveBayes}
\alias{mlNaiveBayes.default}
\alias{mlNaiveBayes.formula}
@@ -92,6 +96,14 @@
\method{predict}{mlLvq}(object, newdata, type = "class", method = c("direct", "cv"),
na.action = na.exclude,...)
+mlSvm(...)
+\method{mlSvm}{default}(train, response, scale = TRUE, type = NULL, kernel = "radial",
+ classwt = NULL, ...)
+\method{mlSvm}{formula}(formula, data, scale = TRUE, type = NULL, kernel = "radial",
+ classwt = NULL, ..., subset, na.action)
+\method{predict}{mlSvm}(object, newdata, type = c("class", "membership", "both"),
+ method = c("direct", "cv"), na.action = na.exclude,...)
+
mlNaiveBayes(...)
\method{mlNaiveBayes}{default}(train, response, laplace = 0, ...)
\method{mlNaiveBayes}{formula}(formula, data, laplace = 0, ..., subset, na.action)
@@ -150,7 +162,8 @@
\code{membership} and \code{both} are almost always available too.
\code{membership} corresponds to posterior probability, raw results,
normalized votes, etc., depending on the machine learning algorithm. With
- \code{both}, class and membership are both returned at once in a list. }
+ \code{both}, class and membership are both returned at once in a list. For
+ \code{mlSvm()}, it is the type of algorithm to use (see \code{?svm}). }
\item{train}{ a matrix or data frame with predictors. }
\item{response}{ a vector of factor (classification) or numeric (regression),
or \code{NULL} (unsupervised classification). }
@@ -177,6 +190,10 @@
\item{k.nn}{ k used for k-NN test of correct classification. Default is 5. }
\item{algorithm}{ an algorithm among 'olvq1' (default, the optimized lvq1),
'lvq1', 'lvq2', or 'lvq3'. }
+ \item{scale}{ are all the variables scaled? If a vector is provided, it is
+ applied to variables with recycling. }
+ \item{kernel}{ the kernel used by svm, see \code{?svm}. Can be "radial",
+ "linear", "polynomial" or "sigmoid". }
\item{laplace}{ positive double controlling Laplace smoothing for the naive
Bayes classifier. The default (0) disables Laplace smoothing. }
}
@@ -202,7 +219,7 @@
\code{\link[MASS]{lda}}, \code{\link[MASS]{qda}},
\code{\link[randomForest]{randomForest}}, \code{\link[class]{olvq1}},
\code{\link[nnet]{nnet}}, \code{\link[e1071]{naiveBayes}},
- \code{\link[RWeka]{make_Weka_classifier}}}
+ \code{\link[e1071]{svm}}}
\examples{
## Prepare data: split into training set (2/3) and test set (1/3)
@@ -335,6 +352,24 @@
confusion(predict(res, newdata = irisTest), irisTest$Species) # Test set perfs
+## Supervised classification using support vector machine
+summary(res <- mlSvm(Species ~ ., data = irisTrain))
+predict(res) # Default type is class
+predict(res, type = "membership")
+predict(res, type = "both")
+confusion(res) # Self-consistency
+confusion(predict(res, newdata = irisTest), irisTest$Species) # Test set perfs
+
+## Another dataset
+summary(res <- mlSvm(Class ~ ., data = HouseVotes84, na.action = na.omit))
+confusion(res) # Self-consistency
+
+## Regression using support vector machine
+summary(ozone.svm <- mlSvm(Ozone ~ ., data = airquality, na.action = na.omit))
+plot(na.omit(airquality)$Ozone, predict(ozone.svm))
+abline(a = 0, b = 1)
+
+
## Supervised classification using naive Bayes
summary(res <- mlNaiveBayes(Species ~ ., data = irisTrain))
predict(res) # Default type is class
Modified: pkg/phytoimage/inst/etc/Conversion.txt
===================================================================
--- pkg/phytoimage/inst/etc/Conversion.txt 2012-08-10 14:09:22 UTC (rev 233)
+++ pkg/phytoimage/inst/etc/Conversion.txt 2012-08-12 23:46:30 UTC (rev 234)
@@ -1,4 +1,4 @@
-Group P1 P2 P3
+Class P1 P2 P3
Copepoda 1 0 1
Cope lateral 1 0 1
Cope dorsal 1 0 1
Modified: pkg/zooimage/DESCRIPTION
===================================================================
--- pkg/zooimage/DESCRIPTION 2012-08-10 14:09:22 UTC (rev 233)
+++ pkg/zooimage/DESCRIPTION 2012-08-12 23:46:30 UTC (rev 234)
@@ -11,7 +11,7 @@
Description: ZooImage is a free (open source) solution for analyzing digital
images of zooplankton. In combination with ImageJ, a free image analysis
system, it processes digital images, measures individuals, trains for
- automatic identification of taxa, and finally, measures zooplankton samples
+ automatic classification of taxa, and finally, measures zooplankton samples
(abundances, total and partial size spectra or biomasses, etc.)
License: GPL (>= 2)
URL: http://www.sciviews.org/zooimage
Modified: pkg/zooimage/NAMESPACE
===================================================================
--- pkg/zooimage/NAMESPACE 2012-08-10 14:09:22 UTC (rev 233)
+++ pkg/zooimage/NAMESPACE 2012-08-12 23:46:30 UTC (rev 234)
@@ -7,26 +7,18 @@
import(filehash)
import(jpeg)
import(png)
-import(ipred)
+#import(ipred)
#import(MASS)
#import(randomForest)
#import(class)
-import(rpart)
-import(e1071)
+#import(rpart)
+#import(e1071)
#import(nnet)
-import(tree)
+#import(tree)
#import(RWeka)
import(mlearning)
#import(party)
-export(histSpectrum)
-export(plotAbdBio)
-#export(processSample)
-#export(processSampleAll)
-export(sampleAbd)
-export(sampleBio)
-export(sampleSpectrum)
-
# Zic
export(zicCheck)
@@ -95,7 +87,12 @@
export(recode)
export(template)
+# ZIRes
+export(processSample)
+export(processSampleAll)
+
# Utilities
+export(addClass)
export(calcVars)
export(calibrate)
export(ecd)
@@ -130,7 +127,7 @@
# GUI
export(aboutZI)
export(acquireImg)
-export(addToTrain)
+export(addVigsToTrain)
export(analyzeClass)
export(calib)
export(closeAssistant)
@@ -157,7 +154,7 @@
export(viewResults)
export(ZIDlg)
# Not in menus yet!
-export(subpartZIDat)
+#export(subpartZIDat)
# GUI-Utilities
export(selectGroups)
@@ -179,7 +176,7 @@
S3method(summary, ZIClass)
S3method(confusion, ZIClass)
-S3method(plot, ZITable)
-S3method(merge, ZITable)
+S3method(print, ZIRes)
+S3method(rbind, ZIRes)
S3method(print, ZIE)
Modified: pkg/zooimage/R/ZIClass.R
===================================================================
--- pkg/zooimage/R/ZIClass.R 2012-08-10 14:09:22 UTC (rev 233)
+++ pkg/zooimage/R/ZIClass.R 2012-08-12 23:46:30 UTC (rev 234)
@@ -52,10 +52,6 @@
attr(ZI.class, "strat") <- cv.strat
}
- ## Make sure the '+others+' group exists
- lev <- levels(ZI.class)
- if (!"+others+" %in% lev) attr(ZI.class, "levels") <- c(lev, "+others+")
-
ZI.class
}
@@ -103,17 +99,17 @@
na.rm = na.rm, ...)
}
-predict.ZIClass <- function (object, ZIDat, calc = TRUE, class.only = TRUE,
+predict.ZIClass <- function (object, newdata, calc = TRUE, class.only = TRUE,
type = "class", ...)
{
## Make sure we have correct objects
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")
+ if (!inherits(newdata, c("ZIDat", "data.frame")))
+ stop("'newdata' must be a 'ZIDat' or 'data.frame' object")
class(object) <- class(object)[-1]
- data <- as.data.frame(ZIDat)
+ data <- as.data.frame(newdata)
if (isTRUE(as.logical(calc)))
data <- attr(object, "calc.vars")(data)
@@ -128,15 +124,16 @@
## Perform the prediction
res <- predict(object, newdata = data, ...)
- ## Return either the prediction, or the ZIDat object with Ident column append/replaced
+ ## Return either the prediction, or the ZIDat object with Predicted
+ ## column append/replaced
if (class.only) res else {
- ZIDat$Ident <- res
- ZIDat
+ newdata$Predicted <- res
+ newdata
}
}
confusion.ZIClass <- function (x, y = response(x),
-labels = c("Actual", "Predicted"), prior, use.cv = TRUE, ...) {
+labels = c("Actual", "Predicted"), useNA = "ifany", prior, use.cv = TRUE, ...) {
## Check labels
labels <- as.character(labels)
if (length(labels) != 2)
@@ -170,9 +167,9 @@
## Construct the confusion object
if (missing(prior)) {
mlearning:::.confusion(data.frame(class1 = y, class2 = class2),
- labels = labels, ...)
+ labels = labels, useNA = useNA, ...)
} else {
mlearning:::.confusion(data.frame(class1 = y, class2 = class2),
- labels = labels, prior = prior, ...)
+ labels = labels, useNA = useNA, prior = prior, ...)
}
}
Deleted: pkg/zooimage/R/ZIMan.R
===================================================================
--- pkg/zooimage/R/ZIMan.R 2012-08-10 14:09:22 UTC (rev 233)
+++ pkg/zooimage/R/ZIMan.R 2012-08-12 23:46:30 UTC (rev 234)
@@ -1,267 +0,0 @@
-## Copyright (c) 2004-2012, Ph. Grosjean <phgrosjean at sciviews.org>
-##
-## This file is part of ZooImage
-##
-## ZooImage is free software: you can redistribute it and/or modify
-## it under the terms of the GNU General Public License as published by
-## the Free Software Foundation, either version 2 of the License, or
-## (at your option) any later version.
-##
-## ZooImage is distributed in the hope that it will be useful,
-## but WITHOUT ANY WARRANTY; without even the implied warranty of
-## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-## GNU General Public License for more details.
-##
-## You should have received a copy of the GNU General Public License
-## along with ZooImage. If not, see <http://www.gnu.org/licenses/>.
-
-## Function to classify vignettes using automatic prediction by a ZIClass object
-classVignettes <- function (zidfile, ZIDat = NULL, Dir = "_manuValidation",
-ZIClass, log = TRUE, ProbaThreshold = NULL, ProbaBio = NULL, DiffMax = 0.2,
-Filter = NULL)
-{
- DirName <- dirname(zidfile)
- ZidName <- noExtension(zidfile)
- ZidDir <- file.path(DirName, ZidName)
-
- ## Check if Directory with the same names as ZIdfile
- if (file.exists(ZidDir) && file.info(ZidDir)$isdir) {
- ## There is a directory which already exists
- stop(paste(ZidName, "already exists in your directory!"))
- }
-
- ## If we want to extract vignette in a directory with a special name
- if (Dir == ZidName) {
- ## Temporary name for vignettes extraction
- ## ... will be renamed at the end of process!
- dir <- paste(ZidName, "_Temp", sep = "")
- ## We have to rename the directory at the end of the process!
- Rename <- TRUE
- } else {
- dir <- Dir
- ## We don't have to rename this directory at the end!
- Rename <- FALSE
- }
-
- ## What is the final Directory name?
- if (Rename) {
- FinalDirName <- ZidDir
- } else {
- FinalDirName <- file.path(DirName, dir)
- }
-
- ## Check Rdata if Rdata exist in the final directory:
- ## useful to add new vignettes to one directory
- ContinueProcess <- TRUE
- if (file.exists(FinalDirName) && file.info(FinalDirName)$isdir) {
- ## There is a directory which already exists
- Pattern <- "_dat1.RData"
- RdataFiles <- list.files(path = FinalDirName, pattern = Pattern)
- ## List Rdata Files in this direcotroy
- if (length(RdataFiles) > 0) { # At least one Rdata in the directory
- ## Check if the current zid file correspond to one RData file
- if (ZidName %in% gsub(Pattern, "", RdataFiles)) {
- ## Stop this zidfile has already been validated
- cat(paste(ZidName, "has already been manually validated in",
- basename(FinalDirName), "directory", "\n", sep = " "))
- ContinueProcess <- FALSE
- }
- }
- }
-
- ## Do we continue the process for this zid file?
- if (isTRUE(ContinueProcess)) {
- ## Do we use a ZIDat object allready recognized?
- if (is.null(ZIDat)) {
- Zid <- zidDatRead(zidfile)
- } else Zid <- ZIDat
-
- ## Code for suspect detection!
-# # Recognition of the zid file only if we don't have a probability
-# if (is.null(attr(Zid, "ProbaParam"))) {
-# Rec <- predict(ZIClass, Zid, proba = TRUE, ProbaBio = ProbaBio,
-# DiffMax = DiffMax)
-# } else {
-# Rec <- Zid
-# }
- ## Code for simple prediction!
- ## Recognition of the zid file only if we don't have an 'Ident' column
- if (!isTRUE("Ident" %in% names(Zid))) {
- Rec <- predict(ZIClass, Zid)
- } else Rec <- Zid
-
- ## Prediction of table
- Predictions <- Rec$Ident
-
- ## Classify only suspect particles
- ## TODO: Suspect_Threshold() is not found!!!
-# if (!is.null(ProbaThreshold))
-# Rec <- Suspect_Threshold(ZIDat = Rec, Threshold = ProbaThreshold)
-
- ## Do we apply a filter?
- if (!is.null(Filter)) {
- Rec <- subpartThreshold(ZIDat = Rec, Filter = Filter)
- cat("Only", nrow(Rec), "filtered vignettes have been classified\n")
- }
-
- ## List of groups in the sample
- Gp <- unique(Rec$Ident)
-
- ## Path of all directories
- if (!is.null(attr(ZIClass, "path"))) {
- ## There is a 'path' attribute associated with the classifer
- GpDir <- file.path(DirName, dir, attr(ZIClass, "path"))
- } else { # Only create classifier without taxonomic relationship
- GpDir <- file.path(DirName, dir, Gp)
- }
-
- ## Create directories for new groups on harddisk
- for (i in 1:length(GpDir)) {
- if (!file.exists(GpDir)[i])
- dir.create(GpDir[i], showWarnings = TRUE, recursive = TRUE)
- }
- zidUncompress(zidfile)
-
- ## Copy vignettes from zidfile directory to group directories
- Rec$Vign <- makeId(Rec)
-
- for (i in 1:nrow(Rec)) {
- From <- file.path(ZidDir, paste(Rec$Vign[i], "jpg", sep = "."))
- To <- file.path(GpDir[basename(GpDir) %in% as.character(Rec$Ident[i])],
- paste(Rec$Vign[i], "jpg", sep = "."))
- file.copy(from = From, to = To, overwrite = FALSE)
- file.remove(From)
- }
-
- ## Copy RData in root directory
- From <- file.path(ZidDir, paste(ZidName, "_dat1.RData", sep = ""))
- To <- file.path(file.path(DirName, dir),
- paste(ZidName, "_dat1.RData", sep = ""))
- file.copy(from = From, to = To, overwrite = FALSE)
- Rdata <- To
- file.remove(From)
-
- ## Remove directory
- unlink(ZidDir, recursive = TRUE)
-
- ## Add Automatic recognition column to Rdata!
- addIdent(RdataFile = Rdata, Auto = Predictions)
-
- if (Rename) # Rename the Directory where the zid file were exported!
- file.rename(from = file.path(dirname(zidfile), dir),
- to = FinalDirName)
-
- ## Message to confirm the end of the treatment
- if (log)
- cat("Vignettes of", ZidName,"have been exported into",
- basename(FinalDirName), "directory\n")
- }
-}
-
-## Loop to classify vignettes from several zid files in _manuValidation
-classVignettesAll <- function (zidfiles, ZIClass, Dir = "_manuValidation",
-log = TRUE)
-{
- for (i in 1:length(zidfiles))
- classVignettes(zidfile = zidfiles[i], ZIClass = ZIClass, Dir = Dir,
- log = log)
- cat("--- Process Done ---\n")
-}
-
-## Function to add 'Ident' column to a ZIDat directly in the Rdata file
-addIdent <- function (RdataFile, Auto)
-{
- if (!is.character(RdataFile))
- stop("'RdataFile' must be the path of the RData file to update")
- ## Load Rdata in memory
- load(file = RdataFile)
-
- ## Add the Ident column
- ZI.sample$Ident <- as.factor(Auto)
-
- ## Replace existing Rdata
- save(ZI.sample, file = RdataFile)
-
- ## Return data invisibly
- invisible(ZI.sample)
-}
-
-# Read manual validation
-ZIManRead <- function (dir, creator = NULL, desc = NULL, keep_ = FALSE,
-na.rm = FALSE)
-{
- ## Use getTrain() function to read vignette
- ManValidation <- getTrain(traindir = dir, creator = creator, desc = desc,
- keep_ = keep_, na.rm = na.rm)
-
- ## Add attributes with names of samples already manually validated
- RDataFiles <- list.files(dir, pattern = "_dat1.RData")
- RDataSamples <- gsub("_dat1.RData", "", RDataFiles)
- attr(ManValidation, "Samples") <- RDataSamples
-
- ## Change classes of the object
- class(ManValidation) <- c("ZIMan", class(ManValidation))
- ManValidation
-}
-
-## Provide groups after manual validation
-reclass <- function (ZIMan)
-{
- ## Check arguments
- if (!inherits(ZIMan, "ZIMan"))
- stop("'ZIMan' must be an object of class 'ZIMan'")
- if (!isTRUE("Class" %in% names(ZIMan)))
- stop("'ZIMan' doesn't contain a column named 'Class'")
-
- ## New identification
- res <- table(ZIMan$Class)
- return(res)
-}
-
-## Confusion matrix before and after Manual validation
-confusionCompa <- function (ZIMan)
-{
- ## Check arguments
- if (!inherits(ZIMan, "ZIMan"))
- stop("'ZIMan' must be an object of class 'ZIMan'")
- if (!isTRUE("Class" %in% names(ZIMan)))
- stop("'ZIMan' does not contain a column named 'Class'")
- if (!isTRUE("Ident" %in% names(ZIMan)))
- stop("'ZIMan' does not contain a column named 'Ident'")
- ## Confusion matrix
- table(Class = ZIMan$Class, Predict = ZIMan$Ident)
-}
-
-## Difference between prediction
-ZIManCompa <- function (ZIMan)
-{
- # Check arguments
- if (!inherits(ZIMan, "ZIMan"))
- stop("'ZIMan' must be an object of class 'ZIMan'")
- if (!isTRUE("Class" %in% names(ZIMan)))
- stop("'ZIMan' does not contain a column named 'Class'")
- if (!isTRUE("Ident" %in% names(ZIMan)))
- stop("'ZIMan' does not contain a column named 'Ident'")
- list(Predicted = table(ZIMan$Ident), Validated = table(ZIMan$Class))
-}
-
-## Substract a ZIDat table according a threshold formula
-subpartThreshold <- function (ZIDat, Filter = NULL)
-{
- ## Do we use a Filter directly?
- if (is.null(Filter)) {
- Threshold <- createThreshold(ZIDat = ZIDat)
- } else {
- if (!is.character(Filter))
- stop("Filter must be like 'Parameter < Value'")
- Threshold <- Filter
- }
- ## Determine particle responding to the threshold
- SubPart <- within(ZIDat, {
- Index <- eval(parse(text = (Threshold)))
- })
-
- res <- ZIDat[SubPart$Index, ]
- attr(res, "Threshold") <- Threshold
- res
-}
Modified: pkg/zooimage/R/ZIRes.R
===================================================================
--- pkg/zooimage/R/ZIRes.R 2012-08-10 14:09:22 UTC (rev 233)
+++ pkg/zooimage/R/ZIRes.R 2012-08-12 23:46:30 UTC (rev 234)
@@ -15,696 +15,339 @@
## You should have received a copy of the GNU General Public License
## along with ZooImage. If not, see <http://www.gnu.org/licenses/>.
-processSample <- function (zidbfile, ZIClass = NULL, use = "both",
-ZIDesc, abd.taxa = NULL, abd.groups = NULL,
-abd.type = "absolute", bio.taxa = NULL, bio.groups = NULL, bio.conv = c(1, 0, 1),
-headers = c("Abd", "Bio"), spec.taxa = NULL, spec.groups = NULL,
-spec.breaks = seq(0.25, 2, by = 0.1), spec.use.Dil = TRUE, exportdir = NULL,
-SemiTab = NULL, Semi = FALSE)
-{
- zidbfile <- as.character(zidbfile)[1]
- if (hasExtension(zidbfile, "zidb")) dbext <- "zidb" else dbext <- "zid"
- if (!checkFileExists(zidbfile, dbext)) return(invisible(FALSE))
-
- ## Check if ZIClass is of the right class
- if (!is.null(ZIClass) && !inherits(ZIClass, "ZIClass")) {
- warning("'ZIClass' must be a 'ZIClass' object")
- return(invisible(FALSE))
+print.ZIRes <- function (x, ...)
+{
+ X <- x
+ class(X) <- "data.frame"
+ print(X)
+ ## Are there size spectra?
+ spectrum <- attr(x, "spectrum")
+ if (length(spectrum)) {
+ cat("\nWith size spectrum:\n")
+ print(spectrum)
}
-
- if (dbext == "zidb") { # This is a ZIDB file
- ZIDat <- zidbDatRead(zidbfile)
- Sample <- sampleInfo(zidbfile, type = "sample",
- ext = extensionPattern(".zidb"))
- RES <- zidbSampleRead(zidbfile)
- } else { # This is an old ZID file
- ZIDat <- zidDatRead(zidbfile)
- Sample <- sampleInfo(zidbfile, type = "sample",
- ext = extensionPattern(".zid"))
- ZIDesc <- zisRead(ZIDesc)
- RES <- ZIDesc[ZIDesc$Label == Sample, ]
- if (nrow(RES) == 0)
- stop("'ZIDesc' has no data for that sample!")
- }
-
-# ## By default, we have to predict zidbfile with a classifier
-# MakePredictions <- TRUE
+ invisible(x)
+}
+
+## TODO... with inspirations from histSpectrum() and plotAbdBio()
+#plot.ZIRes <- function (x, y, ...)
+#{
#
-# ## Modified by Kevin 2010-08-03
-# if (!is.null(ZIMan)) {
-# ## We want to use a ZIMan table
-# if (!inherits(ZIMan, "ZIMan"))
-# stop("'ZIMan' must be a data.frame of class 'ZIMan'")
-#
-# ## List of samples allready manually validated
-# AllSamples <- attr(ZIMan, "Samples")
-#
-# ## Check if manual validation exists for this zid file
-# if (noExtension(ZidFile) %in% AllSamples) {
-# ## The ZidFile was manually validated
-# ## --> use Class column for identification
-# ## Subtable of ZidFile vignettes
-# Vignettes <- makeId(ZIDat)
-# ZIDat <- ZIMan[ZIMan$Id %in% Vignettes, ]
-# ## Sort the table
-# ZIDat <- ZIDat[order(ZIDat$Item), ]
-# ## We don't have to predict this sample anymore!
-# MakePredictions <- FALSE
+#}
+
+#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
+# plot.exp <- isTRUE(as.logical(plot.exp))
+# log.scale <- isTRUE(as.logical(log.scale))
+# if (plot.exp) {
+# spect.lm <- lm(spect ~ class)
+# print(summary(spect.lm))
+# slope <- format(coef(spect.lm)[2], digits = 3)
+# main <- paste(main, " (slope = ", slope, ")", sep = "")
+# class2 <- class - lag
+# spect.lm2 <- lm(spect ~ class2)
+# if (log.scale) {
+# spect <- 10^spect - 1
+# expdat <- 10^predict(spect.lm2) - 1
# }
# }
-
-# if (isTRUE(MakePredictions)) {
-# ## We have to recognize the zid file with a classifier
-# ZIDat <- predict(ZIClass, ZIDat)
+# barplot(spect, width = 0.1, space = 0, xlab = xlab, ylab = ylab,
+# main = main, ylim = ylim)
+# if (plot.exp) {
+# if (log.scale) {
+# abline(coef = coef(spect.lm2), col = 2, lwd = 2)
+# } else {
+# lines(class2, expdat, col = 2, lwd = 2)
+# }
+# return(invisible(spect.lm2))
# }
+#}
+#
+#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, labels = 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")
+#}
- ## Depending on 'us', rework ZIDat$Ident...
- if (use == "Class") {
- ZIDat$Ident <- ZIDat$Class
- } else {
- if (!is.null(ZIClass)) {
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/zooimage -r 234
More information about the Zooimage-commits
mailing list