[Zooimage-commits] r184 - in pkg/zooimage: . R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Apr 9 18:45:04 CEST 2010
Author: phgrosjean
Date: 2010-04-09 18:45:04 +0200 (Fri, 09 Apr 2010)
New Revision: 184
Added:
pkg/zooimage/R/misc.R
Modified:
pkg/zooimage/FunList.txt
pkg/zooimage/NAMESPACE
pkg/zooimage/R/programs.R
pkg/zooimage/R/utilities.R
pkg/zooimage/R/zip.R
pkg/zooimage/man/utilities.Rd
Log:
Rework of utilities and others and placing not exported functions in misc.R
Modified: pkg/zooimage/FunList.txt
===================================================================
--- pkg/zooimage/FunList.txt 2010-04-08 15:30:14 UTC (rev 183)
+++ pkg/zooimage/FunList.txt 2010-04-09 16:45:04 UTC (rev 184)
@@ -1,5 +1,7 @@
-= capabilities.R
+= ZooImage internal functions and objects
+== capabilities.R
+
ZOOIMAGEENV = environment
checkCapable(cap)
capabilities = list
@@ -20,7 +22,7 @@
zooImageCapabilities(...)
-= catcher.R => Nothing exported
+== catcher.R
catch.env = environment
catch(call)
@@ -31,7 +33,7 @@
resetCatcher()
-= errorHandling.R => Nothing exported
+== errorHandling.R
stop(..., call. = TRUE, domain = NULL)
warning(..., call. = TRUE, immediate. = FALSE, domain = NULL)
@@ -50,11 +52,54 @@
extractMessage(err)
-== log.R
-logProcess(message, topic = NULL, file = file.path(tempdir(), "ZooImage.log"),
- logit = TRUE, stop = FALSE, show.log = stop)
-logClear(file = file.path(tempdir(), "ZooImage.log"))
-logView(file = file.path(tempdir(), "ZooImage.log"),
- title = paste(getTemp("ZIname"), "log"), clear = TRUE, warn = FALSE)
-logError(e, msg = NULL, ...)
-logWarning(w, msg = NULL, ...)
\ No newline at end of file
+== misc.R
+
+getSample(x, unique = FALSE, must.have, msg)
+backspaces(n = getOption("width"))
+callStack()
+hasExtension(file, extension = "zip", pattern = extensionPattern(extension))
+list.files.ext(dir, extension = "zip", pattern = extensionPattern(extension), ...)
+list.zim(zidir, ...)
+list.dat1.zim(zidir, ...)
+list.zip(zidir, ...)
+list.zid(zidir, ...)
+extensionPattern(extension = "tif", add.dot = !grepl("[.]", extension))
+checkFileExists(file, extension, message = "file not found: %s", force.file = FALSE)
+checkAllFileExist(files, extension)
+checkDirExists(dir, message = 'Path "%s" does not exist or is not a directory')
+checkEmptyDir(dir, message = "not empty")
+force.dir.create(path, ...)
+checkFirstLine(file, expected = "ZI1", message = 'file "%s" is not a valid ZooImage version 1 file', stop = FALSE)
+list.dir(dir, ...)
+mustbe(x, class, msg)
+mustallbe(..., .list = list(...), class, msg)
+mustmatch(x, y, msg)
+mustallmatch(..., .list = list(...), msg = "all must match")
+mustcontain(container, element, msg)
+mustbeString(x, length)
+template(file = "default.zim", dir = getOption("ZITemplates"))
+finish.loopfunction(ok = TRUE, ok.console.msg = "-- Done! --\n", ok.log.msg = "\n-- OK, no error found. --", nok.console.msg = " -- Done! [ERROR(S) FOUND] --\n", nok.log.msg = "-- Error(s)! --", bell = TRUE, show.log = FALSE, show.console = TRUE)
+zip(zipfile , directory, delete.source = FALSE, comment.file = NULL, delete.zipfile.first = TRUE)
+zip_addcomments(zip, comment.file, on.failure = stop(sprintf(on.failure.msg , comment.file, zip)), on.failure.msg = "problem adding comment from '%s' to file '%s' ", on.success)
+unzip(zipfile, path, delete.source = FALSE)
+zipnote(zipfile, outfile = NULL)
+
+= programs.R
+
+program(prog, args, ..., dir)
+xite(prog, args, ...)
+xite_pnm2biff(input, output)
+xite_statistics(file)
+xite_divide(meangray, image, bf, cor)
+xite_biff2tiff(cor, tif)
+imagemagick(prog, args, ...)
+imagemagick_identify(file)
+imagemagick_convert(file, size1, size2)
+misc(prog, args, ...)
+misc_dcraw(file, arguments, output)
+netpbm(prog, args, ...)
+netpbm_tifftopnm(input, output)
+netpbm_pgmhist(file, delete = TRUE)
+netpbm_ppmtopgm(ppm, pgm)
+editor(file, editor = getOption("ZIEditor"))
+imageViewer(dir = getwd())
Modified: pkg/zooimage/NAMESPACE
===================================================================
--- pkg/zooimage/NAMESPACE 2010-04-08 15:30:14 UTC (rev 183)
+++ pkg/zooimage/NAMESPACE 2010-04-09 16:45:04 UTC (rev 184)
@@ -1,19 +1,19 @@
-import(utils)
-import(tcltk)
-import(tcltk2)
-import(svMisc)
-import(svWidgets)
-import(svDialogs)
-import(ipred)
-import(MASS)
+ import(utils)
+ import(tcltk)
+ import(tcltk2)
+ import(svMisc)
+ import(svWidgets)
+ import(svDialogs)
+ import(ipred)
+ import(MASS)
#import(RandomForest)
-import(class)
-import(rpart)
-import(e1071)
-import(nnet)
-import(tree)
-import(gplots)
-import(RColorBrewer)
+ import(class)
+ import(rpart)
+ import(e1071)
+ import(nnet)
+ import(tree)
+ import(gplots)
+ import(RColorBrewer)
export(Abd.sample)
export(AboutZI)
@@ -21,11 +21,12 @@
export(analyzeClass)
export(BFcorrection)
export(Bio.sample)
-export(calc.vars)
+ export(calc.vars)
export(calib)
export(calibrate)
export(checkBF)
export(clean.after.zid)
+ export(ClearProgress)
export(closeAssistant)
export(closeZooImage)
export(compareExif)
@@ -49,11 +50,11 @@
export(focusGraph)
export(focusR)
export(FormVarsSelect)
-export(getDec)
+ export(getDec)
export(getKey)
export(getList)
export(get.sampleinfo)
-export(gettextZI)
+ export(gettextZI)
export(getVar)
export(get.ZITrain)
export(histSpectrum)
@@ -62,16 +63,16 @@
export(is.zim)
export(list.add)
export(list.dat1.zim)
-export(list.merge)
+ export(list.merge)
export(listObjects)
export(list.samples)
export(list.zim)
export(loadObjects)
-export(logClear)
-export(logError)
-export(logProcess)
-export(logView)
-export(logWarning)
+ export(logClear)
+ export(logError)
+ export(logProcess)
+ export(logView)
+ export(logWarning)
export(lvq)
export(makeClass)
export(make.Id)
@@ -86,7 +87,7 @@
export(nnet2)
export(noext)
export(optInOutDecimalSep)
-export(parse.ini)
+ export(parse.ini)
export(plotAbdBio)
export(plot.ZITable)
export(predict.lvq)
@@ -99,7 +100,7 @@
export(process.sample)
export(process.samples)
export(processSamples)
-export(Progress)
+ export(Progress)
export(RawConvert)
export(read.description)
export(readExifRaw)
@@ -112,7 +113,7 @@
export(saveObjects)
export(selectFile)
export(setKey)
-export(setwd)
+ export(setwd)
export(Spectrum)
export(Spectrum.sample)
export(startPgm)
@@ -138,16 +139,19 @@
export(ZIEimportTable)
export(ZIEimportTif)
export(ZIEimportZie)
-export(ZIpgm)
-export(ZIpgmhelp)
+ export(ZIpgm)
+ export(ZIpgmhelp)
export(zip.img)
export(zip.img.all)
export(zip.ZITrain)
# The following objects are NOT exported
# ZOOIMAGEENV (environment holding ZooImage data)
+ # backspaces
+ # callstack
# catch
# catch.env
+ # chekcAllFileExist
# checkAvailable_java
# checkAvailable_biff2tiff # Eliminate Xite programs
# checkAvailable_divide # Eliminate Xite programs
@@ -158,29 +162,66 @@
# checkCapabilityAvailable
# checkConvertAvailable # Eliminate?
# checkDcRawAvailable # Eliminate?
+ # checkDirExists
+ # checkEmptyDir
+ # checkFileExists
+ # checkFirstLine
# checkIdentifyAvailable # Eliminate?
# checkPpmtopgmAvailable # Eliminate?
# checkUnzipAvailable
# checkZipAvailable
# checkZipnoteAvailable
# dummyCatcher
-# extensionPattern
+ # editor(file, editor = getOption("ZIEditor"))
+ # extensionPattern
# extractMessage
-# finish.loopfunction
+ # finish.loopfunction
+ # force.dir.create
# getCatcher
+ # getSample
# getZooImageCapability
# getZooImageConditionFunction
# getZooImageErrorFunction
# getZooImageWarningFunction
-# grepl
+ # hasExtension
+ # imagemagick(prog, args, ...)
+ # imagemagick_convert(file, size1, size2)
+ # imagemagick_identify(file)
+ # imageViewer(dir = getwd())
+ # list.files.ext
+ # list.dat1.zim
+ # list.dir
+ # list.zim
+ # list.zid
+ # 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)
+ # netpbm_tifftopnm(input, output)
+ # program(prog, args, ..., dir)
# recallWithCatcher
# resetCatcher
# setCatcher
# stop
-# unzip
+ # template
+ # unzip
# warning
-# zip
-# zipnote
+ # xite(prog, args, ...)
+ # xite_biff2tiff(cor, tif)
+ # xite_divide(meangray, image, bf, cor)
+ # xite_pnm2biff(input, output)
+ # xite_statistics(file)
+ # zip
+ # zip_addcomments(
+ # zipnote
# zooImageCapabilities
# zooImageError
# [[.zooImageError
Added: pkg/zooimage/R/misc.R
===================================================================
--- pkg/zooimage/R/misc.R (rev 0)
+++ pkg/zooimage/R/misc.R 2010-04-09 16:45:04 UTC (rev 184)
@@ -0,0 +1,412 @@
+# Copyright (c) 2004-2006, 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/>.
+
+"getSample" <- function (x, unique = FALSE, must.have, msg)
+{
+ res <- sub("[+].*", "", as.character(x))
+ if (isTRUE(unique)) res <- unique(res)
+ if (!missing(must.have)) {
+ if (!all(must.have %in% res)) {
+ if (missing(msg))
+ msg <- sprintf("sample '%s' not in ZIDat",
+ paste(must.have, sep = ","))
+ stop(msg)
+ }
+ }
+ return(res)
+}
+
+"backspaces" <- function (n = getOption("width"))
+ paste(rep("\b", n), collapse = "")
+
+# Get the current call stack
+"callStack" <- function ()
+{
+ calls <- sys.calls()
+ out <- lapply(calls, function(.) {
+ out <- try( as.character(.[[1]] ), silent = TRUE)
+ if (inherits(out, "try-error")) NULL else out
+ })
+ out <- unlist(out[!sapply(out, is.null)])
+ return(out)
+}
+
+# Checks if the file has the extension
+"hasExtension" <- function (file, extension = "zip",
+pattern = extensionPattern(extension))
+ grepl(pattern, file)
+
+# List files with given extension
+# dir: directory to list files
+# extension: file extension to accept. This will be
+# modified by extensionPattern so that the test is case independent
+"list.files.ext" <- function (dir, extension = "zip",
+pattern = extensionPattern(extension), ... )
+{
+ checkDirExists(dir)
+ out <- list.files(dir, pattern = pattern , ...)
+ return(out)
+}
+
+"list.zim" <- function (zidir, ...)
+ list.files.ext(zidir, extension = "zim", ...)
+
+"list.dat1.zim" <- function (zidir, ...)
+ list.files.ext(zidir, extension = "_dat1.zim", ...)
+
+"list.zip" <- function (zidir, ...)
+ list.files.ext(zidir, extension = "zip", ...)
+
+"list.zid" <- function (zidir, ...)
+ list.files.ext(zidir, extension = "zid", ...)
+
+# Transforms a file extension to a pattern for ignore.case matching of the
+# extension: extension (with or without the dot at the beginning)
+# returns a regular expression pattern that can be used
+# to match files with this extension
+# example: extensionPattern("tif")
+"extensionPattern" <- function (extension = "tif",
+add.dot = !grepl("[.]", extension))
+{
+ extensionLetters <- substring(extension, 1:nchar(extension),
+ 1:nchar(extension))
+ parts <- ifelse(extensionLetters %in% c(letters, LETTERS),
+ paste("[", extensionLetters, casefold(extensionLetters, upper = TRUE),
+ "]", sep = ""), extensionLetters)
+ pattern <- paste(parts, collapse = "")
+ if (add.dot) pattern <- paste(".", pattern, sep = "")
+ pattern <- gsub( "[.]", "[.]", pattern)
+ return(paste(pattern, "$", sep = ""))
+}
+
+# Check if a file exists
+# file: file to check
+# extension: if given the file should have this extension
+# message: message to give when the file is not found
+"checkFileExists" <- function (file, extension, message = "file not found: %s",
+force.file = FALSE)
+{
+ message <- sprintf(message, file)
+ if (!file.exists(file)) stop(message)
+ if (force.file && file.info(file)$isdir)
+ stop(sprintf('file "%s" is a directory', file))
+ if (!missing(extension) && !grepl(extensionPattern(extension), file)) {
+ message <- sprintf("'%s' is not a '%s' file", file, extension)
+ stop(message)
+ }
+ return(invisible(NULL))
+}
+
+"checkAllFileExist" <- function (files, extension)
+{
+ if (!all( file.exists(files)))
+ stop("one or more file does not exist")
+ if (!missing(extension) && ! all(hasExtension(files, extension)))
+ stop("one or more files have wrong extension")
+}
+
+# Checks if a directory exists
+# dir: the directory to check
+# message: the message to throw into stop if the directory does
+# not exists or is not a directory
+"checkDirExists" <- function (dir,
+message = 'Path "%s" does not exist or is not a directory')
+{
+ message <- sprintf(message, dir)
+ if (!file.exists(dir) || !file.info(dir)$isdir)
+ stop(message)
+}
+
+"checkEmptyDir" <- function (dir, message = "not empty")
+{
+ if (file.exists(dir)) {
+ if (length(list.files(dir, all.files = TRUE) > 0))
+ stop(message)
+ } else {
+ force.dir.create(dir)
+ }
+}
+
+# Force creation of a directory
+# First, if the path exists but is not a directory, this stops.
+# Then, if it did not exist, it calls dir.create to attempt to create it
+# If the creation was not sucessful, it stops
+# path: the path of the directory to create
+"force.dir.create" <- function (path, ...)
+{
+ if (file.exists(path) && !file.info(path)$isdir)
+ stop ("not a directory")
+ out <- dir.create(path, ...)
+ if (!out)
+ stop("could not create directory")
+ }
+ return(out)
+}
+
+# Checks the first line of a file against some expected content
+"checkFirstLine" <- function (file, expected = "ZI1",
+message = 'file "%s" is not a valid ZooImage version 1 file', stop = FALSE)
+{
+ Line1 <- scan(file, character(), nmax = 1, quiet = TRUE)
+ res <- Line1 == expected
+ if (!res && stop) {
+ message <- sprintf(message, file)
+ stop(message)
+ }
+ return(invisible(res))
+}
+
+"list.dir" <- function (dir, ...)
+{
+ out <- list.files(dir)
+ 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"))
+{
+ f <- file.path(dir, file)
+ checkFileExists(f, message = "template file '%s' does not exist")
+ return(f)
+}
+
+# Called at the looping function (*.all)
+# ok: logical; TRUE if there was a problem
+# ok.console.msg: the message to write to the console if ok is TRUE
+# ok.log.msg: the message to write to the log file if ok is TRUE
+# nok.console.msg: the message to write to the console is ok is FALSE
+# nok.log.msg: the message to write to the log when ok is FALSE
+# show.log: logical; if TRUE the log file is shown at the end
+# show.console: logical; if TRUE messages are written to the console
+# return ok, invisibly
+"finish.loopfunction" <- function (ok = TRUE,
+ok.console.msg = "-- Done! --\n",
+ok.log.msg = "\n-- OK, no error found. --",
+nok.console.msg = " -- Done! [ERROR(S) FOUND] --\n",
+nok.log.msg = "-- Error(s)! --",
+bell = TRUE, show.log = FALSE, show.console = TRUE)
+{
+ # \a rings the bell on most platforms!
+ Bell <- if (bell) "\a"
+
+ # Dispatch
+ if (ok) {
+ logProcess(ok.log.msg)
+ if (show.console) cat(Bell, ok.console.msg , sep = "")
+ } else {
+ logProcess(nok.log.msg)
+ if (show.console) cat(Bell, nok.console.msg, sep = "")
+ }
+
+ # Show the log if needed
+ if (show.log) logView()
+
+ return(invisible(ok))
+}
+
+# Zip the content of the directory into the zipfile
+# and delete the directory if needed
+"zip" <- function (zipfile , directory, delete.source = FALSE,
+comment.file = NULL, delete.zipfile.first = TRUE)
+{
+ # We need the system to be capable of zipping
+ checkZipAvailable()
+
+ # Delete old zip file, if it exists
+ if (delete.zipfile.first && file.exists(zipfile))
+ unlink(zipfile)
+
+ # Test if we need and can add the comment file
+ comment <- !is.null(comment.file) && file.exists(comment.file)
+
+ # Build the list of parameters for zip
+ zippar <- sprintf("-rq9%s%s", if(delete.source) "m" else "",
+ if(comment) "z" else "")
+
+ # Create the basic command
+ cmd <- sprintf('"%s" %s "%s" "%s"', ZIpgm("zip", "misc"), zippar,
+ zipfile, directory)
+
+ # Call the command
+ result <- if (isWin()) {
+ # modify the windows command so that the message is piped into the zip command
+ if (comment) {
+ cmd <- sprintf('%s /c type "%s" | %s', Sys.getenv("COMSPEC"),
+ comment.file, cmd)
+ }
+ system(cmd, show.output.on.console = TRUE, invisible = TRUE)
+ } else {
+ # Modify the command if we need and can add the comment file
+ if (comment)
+ cmd <- sprintf('%s < "%s"', cmd, comment.file)
+ # send the error stream to the null device
+ cmd <- paste(cmd, ' 2> /dev/null')
+ # call the command
+ system(cmd)
+ }
+
+ checkFileExists(zipfile, message = "Error creating zip file '%s'")
+ return(invisible( result == 0))
+}
+
+"zip_addcomments" <- function (zip, comment.file,
+on.failure = stop(sprintf(on.failure.msg , comment.file, zip)),
+on.failure.msg = "problem adding comment from '%s' to file '%s' ", on.success)
+{
+ checkZipAvailable()
+
+ cmd <- if (isWin()) {
+ sprintf('%s /c type "%s" | "%s" -z "%s" ',
+ Sys.getenv("COMSPEC"), comment.file, zip)
+ } else {
+ sprintf('zip -z "%s" < "%s" ', zip, comment.file)
+ }
+ res <- system(cmd, show.output.on.console = FALSE, invisible = TRUE,
+ intern = TRUE)
+ if (res != 0) {
+ on.failure
+ } else if (!missing(on.success)) {
+ on.success
+ }
+ return(invisible(res))
+}
+
+# Unzip a zip file in a directory
+# The function is created differently for R 2.9 (where unzip is available)
+# and other versions of R, where we use a system command
+# this happens at compile time of the package
+# zipfile: the zip file to extract
+# path: the path where to extract
+# delete.source: logical; if TRUE the zipfile is deleted after unzipped
+"unzip" <- if (as.numeric(version$major) >= 2 && as.numeric(version$minor >= 9))
+ # Version for R > 2.9.0
+ function (zipfile, path, delete.source = FALSE) {
+ utils:::unzip(zipfile, exdir = path, overwrite = TRUE)
+ if (delete.source) unlink(zipfile)
+ } else
+# Version for R < 2.9.0
+function (zipfile, path, delete.source = FALSE) {
+ out <- if (isWin()) {
+ zip.unpack(zipfile, path)
+ TRUE
+ } else {
+ cmd <- sprintf('unzip "%s" -d "%s" 2> /dev/null', zipfile, path)
+ out <- system(cmd)
+ out == 0
+ }
+
+ # Delete the zipfile
+ if (delete.source) unlink(zipfile)
+
+ return(invisible(out))
+}
+
+# Extract the comment from the zipfile
+# Comments that are written in the zipfile can be retrieved using
+# the zipnote command, the first lines all start with @ signs, and are not
+# the comment
+# zipfile: the zip file from which to extract the comment
+# outfile: if not NULL, indicates the file the comment should be sent to
+# return the character vector corresponding to the comment. The character
+# vector is still returned when the outfile is used, but it is returned
+# invisibly in that case
+"zipnote" <- function (zipfile, outfile = NULL)
+{
+ # Check that the system is zipnote capable
+ checkZipnoteAvailable()
+
+ # Build the command
+ cmd <- sprintf('"%s" "%s" ' , ZIpgm("zipnote", "misc"), zipfile)
+
+ # Call the command and grab the result
+ out <- if (isWin()) {
+ system(cmd, intern = TRUE, show.output.on.console = FALSE,
+ invisible = TRUE)
+ } else {
+ system(cmd, intern = TRUE)
+ }
+
+ # Filter out things that are not comments
+ out <- out[!grepl("^@", out)]
+
+ # Write the output to the file if needed and return the result
+ if (!is.null(outfile)) {
+ cat(out, file = outfile, sep = "\n")
+ return(invisible(out))
+ } else {
+ return(out)
+ }
+}
Modified: pkg/zooimage/R/programs.R
===================================================================
--- pkg/zooimage/R/programs.R 2010-04-08 15:30:14 UTC (rev 183)
+++ pkg/zooimage/R/programs.R 2010-04-09 16:45:04 UTC (rev 184)
@@ -1,4 +1,4 @@
-# {{{ Copyright (c) 2009, Ph. Grosjean <phgrosjean at sciviews.org>
+# Copyright (c) 2009, Ph. Grosjean <phgrosjean at sciviews.org>
#
# This file is part of ZooImage
#
@@ -14,161 +14,143 @@
#
# You should have received a copy of the GNU General Public License
# along with ZooImage. If not, see <http://www.gnu.org/licenses/>.
-# }}}
-# {{{ program dispatcher
-program <- function( prog, args, ..., dir ){
+# Program dispatcher
+"program" <- function (prog, args, ..., dir)
+{
+ prog <- ZIpgm(prog, dir)
+ cmd <- paste(prog, sprintf(args, ...), sep = " ")
+ system(cmd, intern = TRUE, invisible = TRUE)
- prog <- ZIpgm( prog, dir )
- cmd <- paste( prog, sprintf( args, ... ), sep = " ")
- system( cmd, intern = TRUE, invisible = TRUE )
-
}
-# }}}
-# {{{ xite scripts
-xite <- function( prog, args, ... ){
- program( prog, args, ..., dir = "xite" )
-}
+# Xite scripts
+"xite" <- function (prog, args, ...)
+ program(prog, args, ..., dir = "xite")
-xite_pnm2biff <- function( input, output ){
- if( !file.exists( output ) ){
- xite( "pnm2biff", '"%s" "%s"', input, output)
- checkFileExists( output, message = 'error converting file "%s" to BIFF format' )
+"xite_pnm2biff" <- function (input, output)
+{
+ if (!file.exists(output)) {
+ xite("pnm2biff", '"%s" "%s"', input, output)
+ checkFileExists(output,
+ message = 'error converting file "%s" to BIFF format')
}
}
-xite_statistics <- function( file ){
-
- out <- as.numeric(xite( "statistics", '-m "%s" ', file ) )
- if( is.na( out ) ){
- stop( "Unable to get mean gray value from the blank-field image!" )
+"xite_statistics" <- function (file)
+{
+ out <- as.numeric(xite( "statistics", '-m "%s" ', file))
+ if (is.na(out)) {
+ stop("Unable to get mean gray value from the blank-field image!")
}
- out
+ return(out)
}
-xite_divide <- function( meangray, image, bf, cor ){
-
- out <- xite( "divide", ' -s "%s" "%s" "%s"', image, bf, cor )
- checkFileExists( cor, message = "Error while correcting blank-field for %s" )
-
+"xite_divide" <- function (meangray, image, bf, cor)
+{
+ out <- xite("divide", ' -s "%s" "%s" "%s"', image, bf, cor)
+ checkFileExists(cor, message = "Error while correcting blank-field for %s")
}
-xite_biff2tiff <- function( cor, tif ){
- out <- xite( "biff2tiff", ' "%s" "%s"', cor, tif )
- checkFileExists( tif, message = "Error while converting corrected image to TIFF format!" )
+"xite_biff2tiff" <- function (cor, tif)
+{
+ out <- xite("biff2tiff", ' "%s" "%s"', cor, tif)
+ checkFileExists(tif,
+ message = "Error while converting corrected image to TIFF format!")
}
-# }}}
-# {{{ imagemagick scripts
-imagemagick <- function( prog, args, ... ){
- program( prog, args, ..., dir = "imagemagick" )
-}
+# Imagemagick scripts
+"imagemagick" <- function (prog, args, ...)
+ program(prog, args, ..., dir = "imagemagick")
-imagemagick_identify <- function( file ){
- size <- imagemagick( "identify", ' -format "%s" %s', '%w %h', file )
- size <- as.numeric( strsplit( size, " " ) [[1]] )
- if (is.na(Size) || is.null(Size) || length(Size) != 2 || Size[1] < 100 || Size[2] < 100) {
- stop("Error while getting image size with 'identify'", FileConv )
- }
- size
+"imagemagick_identify" <- function (file)
+{
+ size <- imagemagick("identify", ' -format "%s" %s', '%w %h', file)
+ size <- as.numeric(strsplit(size, " ")[[1]])
+ if (is.na(Size) || is.null(Size) || length(Size) != 2 || Size[1] < 100 ||
+ Size[2] < 100)
+ stop("Error while getting image size with 'identify'", FileConv)
+ return(size)
}
-imagemagick_convert <- function( file, size1, size2 ){
- imagemagick( "convert", ' "%s" -resize %dx%d -median 2.0 -resize %dx%d! "%s"',
- file, size2[1], size2[2], size1[1], size1[2], file )
-}
-# }}}
+"imagemagick_convert" <- function (file, size1, size2)
+ imagemagick("convert", ' "%s" -resize %dx%d -median 2.0 -resize %dx%d! "%s"',
+ file, size2[1], size2[2], size1[1], size1[2], file)
-# {{{ misc
+"misc" <- function (prog, args, ...)
+ program(prog, args, ..., dir = "misc")
-misc <- function( prog, args, ... ){
- program( prog, args, ..., dir = "misc" )
+"misc_dcraw" <- function (file, arguments, output)
+{
+ checkCapable("dc_raw")
+ out <- try(misc("dc_raw", '"%s" %s > "%s" ', file, args, output),
+ silent = TRUE)
+ if (inherits(out, "try-error"))
+ stop(sprintf("error converting '%s' with dc_raw", file))
+ return(out)
}
-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 ) )
- }
- out
-}
-# }}}
+# netpbm scripts
+"netpbm" <- function (prog, args, ...)
+ program(prog, args, ..., dir = "netpbm")
-# {{{ netpbm scripts
-netpbm <- function( prog, args, ... ){
- program( prog, args, ..., dir = "netpbm" )
+"netpbm_tifftopnm" <- function (input, output)
+{
+ unlink(output)
+ res <- netpbm("tifftopnm", ' -byrow "%s" > "%s" ', input, output)
+ checkFileExists(output, message = "Impossible to convert into .pgm image")
+ return(res)
}
-netpbm_tifftopnm <- function(input, output ){
- unlink( output )
- res <- netpbm( "tifftopnm", ' -byrow "%s" > "%s" ', input, output )
- checkFileExists( output, message = "Impossible to convert into .pgm image" )
- res
-}
-
-netpbm_pgmhist <- function( file, delete = TRUE ){
-
- # Create a text file with the statistics of gray levels distribution and read it
- res <- netpbm( "pgmhist", ' "%s" ', file )
+"netpbm_pgmhist" <- function (file, delete = TRUE)
+{
+ # Create a text file with the gray levels distribution and read it
+ res <- netpbm("pgmhist", ' "%s" ', file)
if (delete) unlink(file)
- if (length(res) < 100){
- stop( sprintf("Error while getting histogram of '%s' ", file) )
- }
+ if (length(res) < 100)
+ stop(sprintf("Error while getting histogram of '%s' ", file))
res <- res[-(1:2)] # Eliminate header
- # Keep only two first columns
+ # Keep only the two first columns
res <- sub("\t.*$", "", sub("\t", " ", res))
# Transform into a data frame of numerical values
- BF <- as.data.frame(matrix(as.numeric(unlist(strsplit(res, " "))), ncol = 2, byrow = TRUE))
+ BF <- as.data.frame(matrix(as.numeric(unlist(strsplit(res, " "))),
+ ncol = 2, byrow = TRUE))
names(BF) <- c("Gray", "Count")
- BF
+ return(BF)
}
-
-netpbm_ppmtopgm <- function( ppm, pgm ){
-
- cmd <- if( isWin( ) ){
- sprintf( '%s /c type "%s" | %s > %s',
- Sys.getenv("COMSPEC"), ppm,
- ZIpgm("ppmtopgm", "netpbm"),
- pgm )
+"netpbm_ppmtopgm" <- function (ppm, pgm)
+{
+ cmd <- if (isWin()) {
+ sprintf('%s /c type "%s" | %s > %s', Sys.getenv("COMSPEC"), ppm,
+ ZIpgm("ppmtopgm", "netpbm"), pgm)
} else {
- sprintf( 'ppmtopgm < "%s" > "%s" ', ppm, pgm )
+ sprintf('ppmtopgm < "%s" > "%s" ', ppm, pgm)
}
-
res <- try(system(cmd, invisible = TRUE), silent = TRUE)
- checkFileExists( pgm , message = "problem converting to '%s' using ppmtopgm" )
- unlink( ppm )
- res
-
+ checkFileExists(pgm, message = "problem converting to '%s' using ppmtopgm")
+ unlink(ppm)
+ return(res)
}
-# }}}
-
-# {{{ editor
-editor <- function( file, editor = getOption("ZIEditor" ) ){
- if( !file.exists( editor ) ){
- editor <- getOption( "editor" )
- }
- edit( file = file, editor = editor )
- file
+"editor" <- function (file, editor = getOption("ZIEditor"))
+{
+ if (!file.exists(editor)) editor <- getOption("editor")
+ edit(file = file, editor = editor)
+ return(invisible(file))
}
-# }}}
-
-# {{{ imageViewer
-imageViewer <- function( dir = getwd() ){
- if( isWin() ){
- startPgm( "ImageViewer", sprintf( '"%s"', tools:::file_path_as_absolute(dir) ) )
- } else{
+
+"imageViewer" <- function (dir = getwd())
+{
+ if (isWin()) {
+ startPgm("ImageViewer", sprintf('"%s"',
+ tools:::file_path_as_absolute(dir)))
+ } else {
# TODO: deal with mac
# TODO: maybe we should not rely on nautilus
- cmd <- sprintf( 'nautilus --geometry 600x600 "%s"', dir )
- system( cmd )
+ cmd <- sprintf('nautilus --geometry 600x600 "%s"', dir)
+ system(cmd)
}
}
-# }}}
-
-# :tabSize=4:indentSize=4:noTabs=false:folding=explicit:collapseFolds=1:
Modified: pkg/zooimage/R/utilities.R
===================================================================
--- pkg/zooimage/R/utilities.R 2010-04-08 15:30:14 UTC (rev 183)
+++ pkg/zooimage/R/utilities.R 2010-04-09 16:45:04 UTC (rev 184)
@@ -15,10 +15,20 @@
# You should have received a copy of the GNU General Public License
# along with ZooImage. If not, see <http://www.gnu.org/licenses/>.
+# Masking system so that the warnings related to using windows arguments
+# system <- function (command, intern = FALSE, ignore.stderr = FALSE, wait = TRUE,
+# input = NULL, show.output.on.console = TRUE, minimized = FALSE,
+# invisible = TRUE){
+# {
+# call <- match.call()
+# call[[1]] <- base::system
+# suppressWarnings(eval(call, envir = parent.frame()))
+# }
+
# Various utility functions used by ZooImage
# Get the name of one or several variables of a given class
"getVar" <- function (class = "data.frame", default = "", multi = FALSE,
- title = paste("Choose a ", class, ":", sep = ""), warn.only = TRUE)
+title = paste("Choose a ", class, ":", sep = ""), warn.only = TRUE)
{
# Get one or several variables of a given object class
varlist <- objects(pos = 1) # Get objects in .GlobalEnv
@@ -47,7 +57,7 @@
# Note: this is used as a collection in other languages
# (there is no such collection in R, so, we use az list here!)
"getList" <- function (class = "data.frame", default = "", multi = FALSE,
- title = paste("Choose a list (of ", class, "s):", sep = ""), warn.only = TRUE)
+title = paste("Choose a list (of ", class, "s):", sep = ""), warn.only = TRUE)
{
# Get objects in .GlobalEnv
filter <- function(x) {
@@ -69,8 +79,8 @@
# Select one or several files of a given type
"selectFile" <- function (
- type = c("ZipZid", "ZimZis", "Zip", "Zid", "Zim", "Zis", "Zie"),
- multi = FALSE, quote = TRUE)
+type = c("ZipZid", "ZimZis", "Zip", "Zid", "Zim", "Zis", "Zie"),
+multi = FALSE, quote = TRUE)
{
type <- tryCatch(match.arg(type), error = function (e) {
stop("unrecognized type")
@@ -232,15 +242,15 @@
})
}
-# {{{ list.samples
-#' All sample with at least one entry in a given object
-"list.samples" <- function(obj) {
-
- mustbe( obj, c("ZIDat", "ZIDesc","ZITrain") )
+# 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 = "")))
+ res <- sort(unique(get.sampleinfo(as.character(obj$Label),
+ type = "sample", ext = "")))
return(res)
} else if (inherits(obj, "ZIDesc")) {
res <- sort(unique(as.character(obj$Label)))
@@ -251,34 +261,30 @@
res <- sort(unique(get.sampleinfo(res, type = "sample", ext = "")))
return(res)
}
-
}
-# }}}
-# {{{ parse.ini
-#' Parse an ini file (.zim, .zie, etc.) are ini files!
+# Parse an ini file (.zim, .zie, etc. are .ini files!)
### TODO: manage the case there is no '=' in the data!
-"parse.ini" <- function(data, label = "1") {
- # Parse an ini file (tag=value => 'tag', 'value') and make a list with different sections
+"parse.ini" <- function (data, label = "1")
+{
+ # Parse an ini file (tag=value => 'tag', 'value')
+ # and make a list with different sections
# is str a section
- is.section <- function(str){
- as.logical( length(grep("^\\[.+\\]$", trim(str)) > 0))
- }
+ is.section <- function (str)
+ as.logical(length(grep("^\\[.+\\]$", trim(str)) > 0))
# Get the name of a section
- get.section.name <- function(str){
+ get.section.name <- function (str)
sub("^\\[", "", sub("\\]$", "", trim(str)))
- }
- # Transform a vector of characters into a data frame, possibly with type conversion
- vector.convert <- function(vec) {
+ # Transform a vector of characters into a data frame,
+ # possibly with type conversion
+ vector.convert <- function (vec)
as.data.frame(lapply(as.list(vec), type.convert))
- }
- if (is.null(data) || !inherits(data, "character") || length(data) < 1){
+ if (is.null(data) || !inherits(data, "character") || length(data) < 1)
return(character(0))
- }
# Trim leading and trailing white spaces
data <- trim(data)
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/zooimage -r 184
More information about the Zooimage-commits
mailing list