[Zooimage-commits] r182 - in pkg/zooimage: . R inst/examples man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Apr 8 15:34:51 CEST 2010
Author: phgrosjean
Date: 2010-04-08 15:34:50 +0200 (Thu, 08 Apr 2010)
New Revision: 182
Added:
pkg/zooimage/inst/examples/BIO.2000-05-05.p72.zid
pkg/zooimage/inst/examples/BIO.2000-05-08.p123.zid
pkg/zooimage/inst/examples/Description.zis
Modified:
pkg/zooimage/NAMESPACE
pkg/zooimage/R/capabilities.R
pkg/zooimage/R/utilities.R
pkg/zooimage/man/utilities.Rd
pkg/zooimage/man/zooimage.package.Rd
Log:
Some more cleanup and addition of some example ZID files
Modified: pkg/zooimage/NAMESPACE
===================================================================
--- pkg/zooimage/NAMESPACE 2010-04-08 08:34:53 UTC (rev 181)
+++ pkg/zooimage/NAMESPACE 2010-04-08 13:34:50 UTC (rev 182)
@@ -38,7 +38,7 @@
export(confusion.tree)
export(create.zim)
export(createZis)
-export(ecd)
+ export(ecd)
export(editDescription)
export(edit.zim)
export(editZis)
@@ -51,10 +51,10 @@
export(FormVarsSelect)
export(getDec)
export(getKey)
-export(getList)
-export(get.sampleinfo)
+ export(getList)
+ export(get.sampleinfo)
export(gettextZI)
-export(getVar)
+ export(getVar)
export(get.ZITrain)
export(histSpectrum)
export(importImg)
@@ -74,7 +74,7 @@
export(logWarning)
export(lvq)
export(makeClass)
-export(make.Id)
+ export(make.Id)
export(make.RData)
export(makeTrain)
export(makeZid)
@@ -110,7 +110,7 @@
export(refresh.zims)
export(removeObjects)
export(saveObjects)
-export(selectFile)
+ export(selectFile)
export(setKey)
export(setwd)
export(Spectrum)
@@ -144,27 +144,40 @@
export(zip.img.all)
export(zip.ZITrain)
+# The following functions are NOT exported
+ # ZOOIMAGEENV (environment holding ZooImage data)
# catch
# catch.env
-# checkCapabilityAvailable
-# checkUnzipAvailable
-# checkZipAvailable
-# checkZipnoteAvailable
+ # checkAvailable_java
+ # checkAvailable_biff2tiff # Eliminate Xite programs
+ # checkAvailable_divide # Eliminate Xite programs
+ # checkAvailable_pnm2biff # Eliminate Xite programs
+ # checkAvailable_statistics # Eliminate Xite programs
+ # checkCapabilityAvailable
+ # checkCapable
+ # checkCapabilityAvailable
+ # checkConvertAvailable # Eliminate?
+ # checkDcRawAvailable # Eliminate?
+ # checkIdentifyAvailable # Eliminate?
+ # checkPpmtopgmAvailable # Eliminate?
+ # checkUnzipAvailable
+ # checkZipAvailable
+ # checkZipnoteAvailable
# dummyCatcher
# extensionPattern
# extractMessage
# finish.loopfunction
# getCatcher
-# getZooImageCapability
+ # getZooImageCapability
# getZooImageConditionFunction
# getZooImageErrorFunction
# getZooImageWarningFunction
# grepl
# unzip
-#warning
+# warning
# zip
# zipnote
-# zooImageCapabilities
+ # zooImageCapabilities
# zooImageError
# [[.zooImageError
# zooImageErrorContext
Modified: pkg/zooimage/R/capabilities.R
===================================================================
--- pkg/zooimage/R/capabilities.R 2010-04-08 08:34:53 UTC (rev 181)
+++ pkg/zooimage/R/capabilities.R 2010-04-08 13:34:50 UTC (rev 182)
@@ -1,6 +1,6 @@
# Copyright (c) 2009, Ph. Grosjean <phgrosjean at sciviews.org>
#
-# This file is part of ZooImage .
+# 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
@@ -15,205 +15,177 @@
# You should have received a copy of the GNU General Public License
# along with ZooImage. If not, see <http://www.gnu.org/licenses/>.
-# {{{ ZOOIMAGEENV
ZOOIMAGEENV <- new.env()
-# }}}
-# {{{ checkCapable
-checkCapable <- function( cap ){
- if( cap %in% names( capabilities ) ){
+checkCapable <- function (cap)
+ if (cap %in% names(capabilities))
capabilities[[cap]]()
- }
+
+capabilities <- list(
+ "zip" = checkZipAvailable,
+ "unzip" = checkUnzipAvailable,
+ "zipnote" = checkZipnoteAvailable,
+ "identify" = checkIdentifyAvailable,
+ "convert" = checkConvertAvailable,
+ "ppmtopgm" = checkPpmtopgmAvailable,
+ "dc_raw" = checkDcRawAvailable,
+ "pnm2biff" = checkAvailable_pnm2biff,
+ "divide" = checkAvailable_divide,
+ "statistics" = checkAvailable_statistics,
+ "biff2tiff" = checkAvailable_biff2tiff,
+ "java" = checkAvailable_java
+)
+
+
+# Various check*Capability functions
+# Utility that checks if the zip program is available
+checkZipAvailable <- function ()
+{
+ checkCapabilityAvailable("zip",
+ sprintf('"%s" -h %s', ZIpgm("zip", "misc"),
+ if (!isWin()) " > /dev/null" else ""),
+ "zip - program from Info-Zip not found!")
}
-# }}}
-# {{{ various check*Capability functions
-#{{{ checkZipAvailable
-#' utility that checks if the zip program is available
-checkZipAvailable <- function( ){
- checkCapabilityAvailable( "zip",
- sprintf('"%s" -h %s', ZIpgm("zip", "misc"), if( !isWin() ) " > /dev/null" else "" ),
- "zip - program from Info-Zip not found!" )
+checkUnzipAvailable <- function ()
+{
+ checkCapabilityAvailable("unzip",
+ sprintf('"%s" -h %s', ZIpgm("unzip", "misc"),
+ if (!isWin()) " > /dev/null" else ""),
+ "unzip - program from Info-Zip not found!")
}
-# }}}
-#{{{ checkUnzipAvailable
-checkUnzipAvailable <- function( ){
- checkCapabilityAvailable( "unzip",
- sprintf('"%s" -h %s', ZIpgm("unzip", "misc"), if( !isWin() ) " > /dev/null" else "" ),
- "unzip - program from Info-Zip not found!" )
+checkZipnoteAvailable <- function ()
+{
+ checkCapabilityAvailable("zipnote",
+ sprintf('"%s" -h %s', ZIpgm("zipnote", "misc"),
+ if(!isWin()) " > /dev/null" else ""),
+ "zipnote - program from Info-Zip not found!")
}
-#}}}
-#{{{ checkZipnoteAvailable
-checkZipnoteAvailable <- function( ){
- checkCapabilityAvailable( "zipnote",
- sprintf('"%s" -h %s', ZIpgm("zipnote", "misc"), if( !isWin() ) " > /dev/null" else "" ),
- "zipnote - program from Info-Zip not found!" )
+checkIdentifyAvailable <- function ()
+{
+ checkCapabilityAvailable("identify",
+ sprintf('"%s" -version ', ZIpgm("identify", "imagemagick")),
+ "program not found! Install ImageMagick 16 bit!")
}
-# }}}
-# {{{ checkIdentifyAvailable
-checkIdentifyAvailable <- function( ){
- checkCapabilityAvailable( "identify",
- sprintf('"%s" -version ', ZIpgm("identify", "imagemagick") ),
- "program not found! Install ImageMagick 16 bit!" )
+checkConvertAvailable <- function ()
+{
+ checkCapabilityAvailable("convert",
+ sprintf('"%s" -version ', ZIpgm("convert", "imagemagick")),
+ "program not found! Install ImageMagick 16 bit!")
}
-# }}}
-# {{{ checkConvertAvailable
-checkConvertAvailable <- function( ){
- checkCapabilityAvailable( "convert",
- sprintf('"%s" -version ', ZIpgm("convert", "imagemagick") ),
- "program not found! Install ImageMagick 16 bit!" )
+checkPpmtopgmAvailable <- function ()
+{
+ checkCapabilityAvailable("ppmtopgm",
+ sprintf('"%s" -help ', ZIpgm("ppmtopgm", "netpbm")),
+ "ppmtopgm: program not found! Please, install it!")
}
-# }}}
-# {{{ checkPpmtopgmAvailable
-checkPpmtopgmAvailable <- function( ){
- checkCapabilityAvailable( "ppmtopgm",
- sprintf('"%s" -help ', ZIpgm("ppmtopgm", "netpbm") ),
- "ppmtopgm : program not found!" )
+checkDcRawAvailable <- function ()
+{
+ checkCapabilityAvailable("dc_raw",
+ sprintf('"%s" -help ', ZIpgm("dc_raw", "misc")),
+ "dc_raw: program not found! Please, install it!")
}
-# }}}
-# {{{ checkDcRawAvailable
-checkDcRawAvailable <- function( ){
- checkCapabilityAvailable( "dc_raw",
- sprintf('"%s" -help ', ZIpgm("dc_raw", "misc") ),
- "dc_raw : program not found!" )
+checkAvailable_pnm2biff <- function ()
+{
+ checkCapabilityAvailable("pnm2biff",
+ sprintf('"%s" -version ', ZIpgm("pnm2biff", "xite")),
+ "pnm2biff: program not found! Please, install xite!")
}
-# }}}
-# {{{ xite
-checkAvailable_pnm2biff <- function( ){
- checkCapabilityAvailable( "pnm2biff",
- sprintf('"%s" -version ', ZIpgm("pnm2biff", "xite") ),
- "pnm2biff : program not found!" )
+checkAvailable_divide <- function ()
+{
+ checkCapabilityAvailable("divide",
+ sprintf('"%s" -version ', ZIpgm("divide", "xite")),
+ "divide: program not found! Please, install xite!")
}
-checkAvailable_divide <- function( ){
- checkCapabilityAvailable( "divide",
- sprintf('"%s" -version ', ZIpgm("divide", "xite") ),
- "divide : program not found!" )
+
+checkAvailable_statistics <- function ()
+{
+ checkCapabilityAvailable("statistics",
+ sprintf('"%s" -version ', ZIpgm("statistics", "xite")),
+ "statistics: program not found! Please, install xite!")
}
-checkAvailable_statistics <- function( ){
- checkCapabilityAvailable( "statistics",
- sprintf('"%s" -version ', ZIpgm("statistics", "xite") ),
- "statistics : program not found!" )
+
+checkAvailable_biff2tiff <- function ()
+{
+ checkCapabilityAvailable("biff2tiff",
+ sprintf('"%s" -version ', ZIpgm("biff2tiff", "xite")),
+ "biff2tiff: program not found! Please, install xite!")
}
-checkAvailable_biff2tiff <- function( ){
- checkCapabilityAvailable( "biff2tiff",
- sprintf('"%s" -version ', ZIpgm("biff2tiff", "xite") ),
- "biff2tiff : program not found!" )
-}
-# }}}
-# {{{ java
-checkAvailable_java <- function( ){
- checkCapabilityAvailable( "java",
+checkAvailable_java <- function ()
+{
+ checkCapabilityAvailable("java",
'java -version ',
- "java : program not found!" )
+ "java: program not found! Please, install it!")
}
-# }}}
-# }}}
-# {{{ capabilities
-capabilities <- list(
- "zip" = checkZipAvailable ,
- "unzip" = checkUnzipAvailable,
- "zipnote" = checkZipnoteAvailable ,
- "identify" = checkIdentifyAvailable,
- "convert" = checkConvertAvailable,
- "ppmtopgm" = checkPpmtopgmAvailable,
- "dc_raw" = checkDcRawAvailable,
- "pnm2biff" = checkAvailable_pnm2biff,
- "divide" = checkAvailable_divide,
- "statistics" = checkAvailable_statistics,
- "biff2tiff" = checkAvailable_biff2tiff,
- "java" = checkAvailable_java
- )
-# }}}
-
-#{{{ checkCapabilityAvailable
-checkCapabilityAvailable <- function( cap, cmd, msg ){
-
+checkCapabilityAvailable <- function (cap, cmd, msg)
+{
program <- cap
- if( program == "dc_raw" && !isWin() ) {
- program <- "dcraw"
- }
+ if (program == "dc_raw" && !isWin()) program <- "dcraw"
- # function called when zip is not available
- stopHere <- function( ){
- stop( msg )
- }
+ # Function called when zip is not available
+ stopHere <- function () stop(msg)
- # check if we don't already know about that
- zipCap <- getZooImageCapability( cap )
- if( !is.null( zipCap ) ){
- if( !isTRUE(zipCap) ){
- stopHere( )
- } else{
- return( invisible( NULL ) )
+ # Check if we don't already know about that
+ zipCap <- getZooImageCapability(cap)
+ if (!is.null(zipCap)) {
+ if (!isTRUE(zipCap)) {
+ stopHere()
+ } else {
+ return(invisible(NULL))
}
}
# [RF,20090219] the invisible flag gives a warning outside of windows
# and we do not want this warning to be captured by our
# error trapping
- ok <- if( isWin() ){
+ ok <- if (isWin()) {
system(cmd, invisible = TRUE) == 0
} else {
- length(
- system( sprintf( " which %s 2> /dev/null" , program ), intern = TRUE )
- ) > 0
+ length(system(sprintf(" which %s 2> /dev/null" , program),
+ intern = TRUE)) > 0
}
- # cache the result for next time, so that we don't have to check again
- arguments <- list( cap = ok )
- names( arguments ) <- cap
- zooImageCapabilities( arguments )
- if( !ok ) {
- stopHere()
- }
-
+ # Cache the result for next time, so that we don't have to check again
+ arguments <- list(cap = ok)
+ names(arguments) <- cap
+ zooImageCapabilities(arguments)
+ if (!ok) stopHere()
}
-#}}}
-#{{{ getZooImageCapability
-getZooImageCapability <- function( cap = "zip" ){
- ZOOIMAGEENV[[ cap ]]
-}
-# }}}
+getZooImageCapability <- function (cap = "zip")
+ ZOOIMAGEENV[[cap]]
-# {{{ zooImageCapabilities
-zooImageCapabilities <- function( ... ){
- dots <- list( ... )
- if( length(dots) == 1 && is.list(dots[[1]]) ){
- dots <- dots[[1]]
- }
- snapshot <- structure( as.list( ZOOIMAGEENV ), class = "zooimagecapabilities" )
+zooImageCapabilities <- function (...)
+{
+ dots <- list(...)
+ if (length(dots) == 1 && is.list(dots[[1]]))
+ dots <- dots[[1]]
+ snapshot <- structure(as.list(ZOOIMAGEENV), class = "zooimagecapabilities")
- if( length(dots) ) {
- # checking that dots have names
- if( is.null(names(dots)) || any( names( dots ) == "" ) ){
- stop( "capabilities must have names" )
- }
+ if (length(dots)) {
+ # Checking that dots have names
+ if (is.null(names(dots)) || any(names(dots) == ""))
+ stop("capabilities must have names")
- # checking that each capability is a logicial of length one
- check <- function( x ){
- is.logical(x) && length(x) == 1
- }
- if( any( ! sapply( dots, check ) ) ){
- stop( "capability are logicals of length one" )
- }
+ # Checking that each capability is a logicial of length one
+ check <- function (x)
+ is.logical(x) && length(x) == 1
+
+ if (any(!sapply(dots, check)))
+ stop("capability are logicals of length one")
- # store the capability in the .zooimageenv environment
- for( cap in names(dots) ){
- ZOOIMAGEENV[[cap]] <- dots[[cap]]
- }
- }
- snapshot
+ # Store the capability in the ZOOIMAGEENV environment
+ for (cap in names(dots))
+ ZOOIMAGEENV[[cap]] <- dots[[cap]]
+ }
+ return(snapshot)
}
-# }}}
-
-# :tabSize=4:indentSize=4:noTabs=false:folding=explicit:collapseFolds=1:
Modified: pkg/zooimage/R/utilities.R
===================================================================
--- pkg/zooimage/R/utilities.R 2010-04-08 08:34:53 UTC (rev 181)
+++ pkg/zooimage/R/utilities.R 2010-04-08 13:34:50 UTC (rev 182)
@@ -1,6 +1,6 @@
# Copyright (c) 2004-2006, Ph. Grosjean <phgrosjean at sciviews.org>
#
-# This file is part of ZooImage .
+# 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
@@ -16,119 +16,112 @@
# along with ZooImage. If not, see <http://www.gnu.org/licenses/>.
# Various utility functions used by ZooImage
-
-# {{{ warnOrStop
-#' warns or stops
-warnOrStop <- function( ..., warn.only = get("warn.only", parent.frame() ) ){
- if( is.null(warn.only ) ) warn.only <- TRUE
- msg <- paste( ..., sep = "" )
- if( warn.only ) warning( msg ) else stop( msg )
- invisible( NULL )
-}
-# }}}
-
-# {{{ getVar
-#' 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) {
-
+# 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)
+{
# Get one or several variables of a given object class
- (require(utils) || stop("Package 'utils' is required!"))
- varlist <- objects(pos = 1) # Get objects in .GlobalEnv
+ varlist <- objects(pos = 1) # Get objects in .GlobalEnv
# Filter this list to keep only object inheriting a giving class...
Filter <- NULL
- for (i in 1:length(varlist)) {
+ for (i in 1:length(varlist))
Filter[i] <- inherits(get(varlist[i]), class)
- }
# Keep only those objects
varlist <- varlist[Filter]
if (length(varlist) == 0) { # No such objects in .GlobalEnv
- warnOrStop( "There is no object of class '", paste(class, collapse = " "), "' in the user workspace!" )
+ msg <- paste("There is no object of class '",
+ paste(class, collapse = " "), "' in the user workspace!", sep = "")
+ if (isTRUE(warn.only)) warning(msg) else stop(msg)
varsel <- ""
} else {
if (default == "") default <- varlist[1]
- varsel <- select.list(varlist, preselect = default, multiple = multi, title = title)
+ varsel <- select.list(varlist, preselect = default, multiple = multi,
+ title = title)
}
return(varsel)
}
-# }}}
-# {{{ getList
-#' Get the name of one or several lists with all of their components of a given class
-#' Note: this is used as a collection in other languages (no such collection in R!)
-"getList" <- function(class = "data.frame", default = "", multi = FALSE,
- title = paste("Choose a ", class, ":", sep=""), warn.only = TRUE) {
-
- # Get lists of items of specified class
- (require(utils) || stop("Package 'utils' is required!"))
-
+# Get the name of one or more lists with their components of a given class
+# 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)
+{
# Get objects in .GlobalEnv
filter <- function(x) {
item <- get(x)
- is.list(item) && all( sapply( item, function(y) inherits( y, class ) ) )
+ is.list(item) && all(sapply(item, function(y) inherits(y, class)))
}
- varlist <- Filter( filter , objects(pos = 1) )
- if( length(varlist) == 0 ){
- warnOrStop( "There is no list of ", class, " objects in the user workspace" )
+ varlist <- Filter(filter, objects(pos = 1))
+ if (length(varlist) == 0) {
+ msg <- paste("There is no list of '", class,
+ "' objects in the user workspace", sep = "")
+ if (isTRUE(warn.only)) warning(msg) else stop(msg)
return("")
}
- if (default == ""){
- default <- varlist[1]
- }
- varsel <- select.list(varlist, preselect = default, multiple = multi, title = title)
+ if (default == "") default <- varlist[1]
+ varsel <- select.list(varlist, preselect = default, multiple = multi,
+ title = title)
return(varsel)
}
-# }}}
-# {{{ selectFile
-#' Select one or several files of a given type
-"selectFile" <- function(
+# 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 <- tryCatch( match.arg( type ), error = function(e){
- stop( "unrecognized type" )
+ multi = FALSE, quote = TRUE)
+{
+ type <- tryCatch(match.arg(type), error = function (e) {
+ stop("unrecognized type")
})
- Type <- switch( type, "ZipZid" = "Zip/Zid", "ZimZis" = "Zim/Zis", type )
+ Type <- switch(type, "ZipZid" = "Zip/Zid", "ZimZis" = "Zim/Zis", type)
# Adapt title according to 'multi'
- if (multi) {
+ if (isTRUE(multi)) {
title <- paste("Select one or several", Type, "files...")
} else {
title <- paste("Select one", Type, "file...")
}
- 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" ))
- res <- choose.files(caption = title, multi = multi, filters = filters )
- if (res != "" && quote) {
+ #if (!isWin()) {
+ filters <- switch(type,
+ ZipZid = c("ZooImage files" , ".zip",
+ "ZooImage files" , ".zid" ),
+ ZimZis = c("ZooImage metadata files" , ".zim",
+ "ZooImage metadata files" , ".zis" ),
+ Zip = c("ZooImage picture files" , ".zip" ),
+ Zid = c("ZooImage data files" , ".zid" ),
+ Zim = c("ZooImage metadata files" , ".zim" ),
+ Zis = c("ZooImage sample files" , ".zis" ),
+ Zie = c("ZooImage extension files", ".zie" ))
+ 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)
}
-# }}}
-# {{{ getKey / setKey
-
-# Get a key in the registry (retrieve ZooImage configuration data)
-ziKey <- function( key ){
- sprintf( "zooimage-%s", key )
-}
-
-"getKey" <- function(key, default.value = NULL) {
-
+# Get a key (permanent configuration data, from the registry if under Windows)
+"getKey" <- function (key, default.value = NULL)
+{
# Retrieve a ZooImage key in the registry
# TODO: should we use this also for windows ?
if (!isWin()) {
- return( getTemp( ziKey(key) , default.value) )
+ return(getTemp(sprintf("zooimage-%s", key), default.value))
}
# Look if the key is defined
@@ -140,124 +133,104 @@
}
-# Set a key in the registry (store configuration data for next ZooImage session)
-"setKey" <- function(key, value, type = "sz") {
+# Set a key permanently (in the registry, if under Windows)
+"setKey" <- function (key, value, type = "sz")
+{
if(!isWin()) {
# TODO: should we also use this for windows ?
- assignTemp( ziKey( key), value, TRUE )
+ assignTemp(sprintf("zooimage-%s", key), value, TRUE )
} else{
tk2reg.set(getTemp("ZIkey"), key, value, type = "sz")
}
return(invisible(TRUE))
}
-# }}}
-# {{{ Text manipulation
-#' Convert underscores into spaces
-"underscore2space" <- function(char) {
- # Convert underscores to spaces in strings (underscore is used in calltips
- # in the ZooImage Metadata Editor, because of a bug in this program)
- gsub("_", " ", char)
-}
+# Convert underscores into spaces
+"underscore2space" <- function (char)
+ return(gsub("_", " ", char))
-#' Trim leading and trailing white spaces and tabs
-"trim" <- function(char) {
- sub("\\s+$", "", sub("^\\s+", "", char))
-}
+# Trim leading and trailing white spaces and tabs
+"trim" <- function (char)
+ return(sub("\\s+$", "", sub("^\\s+", "", char)))
-#' Get the name of a file, without its extension
-"noext" <- function(file) {
- # Get basename without extension
- sub("\\.[^.]+$", "", basename(file))
-}
+# Get the name of a file, without its extension
+"noext" <- function (file)
+ return(sub("\\.[^.]+$", "", basename(file)))
-# }}}
-
-# {{{ get.sampleinfo
# Get information about a sample, given its name
-"get.sampleinfo" <- function(filename,
- type = c("sample", "fraction", "image", "scs", "date", "id", "frac", "imgnbr"),
- ext = "_dat1[.]zim$") {
-
- type <- tryCatch( match.arg(type), error = function(e){
- stop("'type' must be 'sample', 'fraction', 'image', 'scs', 'date', 'id', 'frac' or 'imgnbr'")
- } )
+"get.sampleinfo" <- function (filename, type = c("sample", "fraction", "image",
+"scs", "date", "id", "frac", "imgnbr"), ext = "_dat1[.]zim$")
+{
+ type <- tryCatch( match.arg(type), error = function (e) {
+ stop("'type' must be 'sample', 'fraction', 'image', 'scs', 'date', 'id',
+ 'frac' or 'imgnbr'")
+ })
base <- basename(filename)
- if (ext != ""){
- base <- sub(ext, "", base)
- }
+ if (ext != "") base <- sub(ext, "", base)
- # filename without extension is supposed to follow the convention: scs.date.id+f[img]
- # with scs.date.id forming an unique sample identifier
- # Note: not all verifications are conducted. So, it sometimes returns a result even if the name does
- # not conform to this specification!
- ### TODO: check that the name follows the convention and determine what is facultative, like date, for instance)
+ # Filename without extension is supposed to follow the convention:
+ # scs.date.id+f[img] with scs.date.id forming an unique sample identifier
+ # Note: not all verifications are conducted. So, it sometimes returns a
+ # result even if the name does not conform to this specification!
+ ### TODO: check that the name follows the convention and determine what is
+ # optional, like date, for instance)
res <- switch(type,
- sample = sub("\\+[a-zA-Z][0-9.]+$", "", base),
- fraction = sub("[0-9.]+$", "", base),
- image = base,
- scs = sub("^[^+.]*[+.].+$", "", base),
- date = as.Date(sub("^.*([0-9]{4}-[0-1][0-9]-[0-3][0-9]).*$", "\\1", base)),
- id = sub("^.*\\..*\\.(.*)\\+.*$", "\\1", base),
- frac = sub("^.*\\+([a-zA-Z]).*$", "\\1",base),
- imgnbr = as.numeric(sub("^.*\\+[a-zA-Z]([0-9.]*)$", "\\1", base)),
- )
+ sample = sub("\\+[a-zA-Z][0-9.]+$", "", base),
+ fraction = sub("[0-9.]+$", "", base),
+ image = base,
+ scs = sub("[+.].+$", "", base),
+ date = as.Date(sub("^.*([0-9]{4}-[0-1][0-9]-[0-3][0-9]).*$", "\\1",
+ base)),
+ id = sub("^.*\\..*\\.(.*)\\+.*$", "\\1", base),
+ frac = sub("^.*\\+([a-zA-Z]).*$", "\\1",base),
+ imgnbr = as.numeric(sub("^.*\\+[a-zA-Z]([0-9.]*)$", "\\1", base)),
+ )
return(res)
}
-# }}}
-# {{{ ecd
-#' Calculate equivalence circular diameter (similar to equivalent spherical diameter, but for 2D images)
-"ecd" <- function(area) {
+# Calculate equivalent circular diameter (similar to equivalent spherical
+# diameter, but for 2D images)
+"ecd" <- function (area)
return(2 * sqrt(area / pi))
-}
-# }}}
-# {{{ make.Id
-#' Unique identifiers (Ids) are a combination of Label and Item
-"make.Id" <- function(df) {
- # Make a list of Ids, combining "Label" and "Item"
+# Unique identifiers (Ids) are a combination of Label and Item
+"make.Id" <- function (df)
paste(df$Label, df$Item, sep = "_")
-}
-# }}}
-# {{{ calc.vars
-#' Calculate derived variables... default function
-"calc.vars" <- function(x) {
-
+# Calculate derived variables... default function
+"calc.vars" <- function (x)
+{
# This is the calculation of derived variables
- # Note that you can make your own version of this function for more calculated variables!
+ # Note that you can make your own version of this function for more
+ # calculated variables!
# A small hack to correct some 0 for Minor and Major
- hack <- function( x ){
- x[ x == 0 ] <- 0.000000001
- }
- distfun <- function( x, y ){
- sqrt( x^2 + y^2 )
- }
+ hack <- function (x)
+ x[x == 0] <- 0.000000001
+ distfun <- function (x, y)
+ sqrt(x^2 + y^2)
- within( x, {
- Minor <- hack( Minor )
- Major <- hack( Major )
+ within(x, {
+ Minor <- hack(Minor)
+ Major <- hack(Major)
Elongation <- Major / Minor
- CentBoxD <- distfun( BX + Width/2 - X , BY + Height/2 - Y )
- GrayCentBoxD <- distfun( BX + Width/2 - XM , BY + Height/2 - YM )
- CentroidsD <- distfun( X - XM , Y - YM )
+ CentBoxD <- distfun(BX + Width/2 - X, BY + Height/2 - Y)
+ GrayCentBoxD <- distfun(BX + Width/2 - XM, BY + Height/2 - YM)
+ CentroidsD <- distfun(X - XM, Y - YM)
Range <- Max - Min
MeanPos <- (Max - Mean) / Range
SDNorm <- StdDev / Range
CV <- StdDev / Mean * 100
- Area <- hack( Area )
+ Area <- hack(Area)
logArea <- log(Area)
- Perim. <- hack( Perim. )
+ Perim. <- hack(Perim.)
logPerim. <- log(Perim.)
logMajor <- log(Major)
logMinor <- log(Minor)
- Feret <- hack( Feret )
+ Feret <- hack(Feret)
logFeret <- log(Feret)
- } )
+ })
}
-# }}}
# {{{ list.samples
#' All sample with at least one entry in a given object
@@ -541,70 +514,60 @@
# Save the current default directory for future use
setKey("DefaultDirectory", getwd())
}
-# }}}
-# {{{ ZIpgm
-#' Get the path of an executable, giving its name and subdirectory
-#' @examples
-#' ZIpgm("zip")
-#' ZIpgm("pgmhist", "netpbm")
-#' ZIpgm("pnm2biff", "xite")
-"ZIpgm" <- function(pgm, subdir = "misc", ext = "exe") {
-
+# Get the path of an executable, giving its name and subdirectory
+# ex.: ZIpgm("zip"), ZIpgm("pgmhist", "netpbm"), ZIpgm("pnm2biff", "xite")
+"ZIpgm" <- function (pgm, subdir = "misc", ext = "exe")
+{
if (isWin()) {
- pathpgm <- system.file(subdir, "bin", paste(pgm, ext, sep = "."), package = "zooimage")
- if (!file.exists(pathpgm)) return("") else return(shortPathName(pathpgm))
+ pathpgm <- system.file(subdir, "bin", paste(pgm, ext, sep = "."),
+ package = "zooimage")
+ if (!file.exists(pathpgm)) return("") else
+ return(shortPathName(pathpgm))
} else {
# Change nothing: should be directly executable
- if( pgm == "dc_raw" ) {
- pgm <- "dcraw"
- }
+ if (pgm == "dc_raw") pgm <- "dcraw"
return(pgm)
}
}
-# }}}
-# {{{ ZIpgmhelp
-#' Show textual help for executables
-#' @examples
-#' ZIpgmhelp("zip")
-#' ZIpgmhelp("pgmhist", "netpbm")
-#' ZIpgmhelp("pnm2biff", "xite")
-"ZIpgmhelp" <- function(pgm, subdir = "misc") {
+# Show textual help for executables
+# ex.: ZIpgmhelp("zip"), ZIpgmhelp("pgmhist", "netpbm")
+"ZIpgmhelp" <- function (pgm, subdir = "misc")
+{
# TODO: would it not be better to use the same thing on all platforms
# (the doc directory)
if (isWin()) {
- helpfile <- file.path(system.file(subdir, "doc", package = "zooimage"), paste(pgm, "txt", sep = "."))
- if (!file.exists(helpfile)){
+ helpfile <- file.path(system.file(subdir, "doc", package = "zooimage"),
+ paste(pgm, "txt", sep = "."))
+ if (!file.exists(helpfile))
stop("No help found for ", pgm)
- }
- file.show(helpfile, title = paste("Help for ", pgm, " [", subdir, "]", sep = ""))
+ file.show(helpfile, title = paste("Help for ", pgm, " [", subdir, "]",
+ sep = ""))
} else {
system(paste("man", pgm), wait = FALSE)
}
}
-# }}}
-# {{{ getDec
-"getDec" <- function() {
+"getDec" <- function ()
+{
Dec <- getKey("OptionInOutDecimalSep", ".")
DecList <- c(".", ",")
# It must be either "." or ","!
if (!Dec %in% DecList) Dec <- "."
return(Dec)
}
-# }}}
-# {{{ callStack
-#' Get the current call stack
-callStack <- function( ){
+# 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 ) ] )
- out
+ 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)
}
# }}}
Added: pkg/zooimage/inst/examples/BIO.2000-05-05.p72.zid
===================================================================
(Binary files differ)
Property changes on: pkg/zooimage/inst/examples/BIO.2000-05-05.p72.zid
___________________________________________________________________
Name: svn:executable
+ *
Name: svn:mime-type
+ application/octet-stream
Added: pkg/zooimage/inst/examples/BIO.2000-05-08.p123.zid
===================================================================
(Binary files differ)
Property changes on: pkg/zooimage/inst/examples/BIO.2000-05-08.p123.zid
___________________________________________________________________
Name: svn:executable
+ *
Name: svn:mime-type
+ application/octet-stream
Added: pkg/zooimage/inst/examples/Description.zis
===================================================================
--- pkg/zooimage/inst/examples/Description.zis (rev 0)
+++ pkg/zooimage/inst/examples/Description.zis 2010-04-08 13:34:50 UTC (rev 182)
@@ -0,0 +1,26 @@
+ZI1
+[Description]
+Id=Bioman
+Name=Bioman series
+Institution=AZTI Technalia
+Objective=
+Description=
+Contact=Xabier Irigoien
+Email=xirigoien at pas.azti.es
+URL=
+Note=
+
+[Series]
+!Code Name Project Institution Country Location Contact Email URL Note
+BIO Bioman AZTI Technalia Spain Bay of Biscay Xabier Irigoien xirigoien at pas.azti.es PVA samples
+
+[Cruises]
+!Code ShipName ShipType ShipCallSign PortDeparture PortReturn Captain Coordinator Investigators Start End SouthmostLat WestmostLong NorthmostLat EastmostLong Project URL Note
+
+[Stations]
+!Code Location Latitude Longitude Start End Frequency Depth Description Note
+
+[Samples]
+!Label Code SCS Series Cruise Station Date Time TimeZone Latitude Longitude CoordsPrec Operator GearType OpeningArea MeshSize DepthMin DepthMax SampVol SampVolPrec TowType Speed Weather Preservative Staining Biovolume Temperature Salinity Chla Note
+BIO.2000-05-05.p72 P72 BIO BIO 2000-05-05 Vertical Net 150 10.56 vertical 4% buffered formalin Haematoxylin
+BIO.2000-05-08.p123 p123 BIO BIO 2000-05-08 Vertical Net 150 10.97 vertical 4% buffered formalin Haematoxylin
Property changes on: pkg/zooimage/inst/examples/Description.zis
___________________________________________________________________
Name: svn:executable
+ *
Modified: pkg/zooimage/man/utilities.Rd
===================================================================
--- pkg/zooimage/man/utilities.Rd 2010-04-08 08:34:53 UTC (rev 181)
+++ pkg/zooimage/man/utilities.Rd 2010-04-08 13:34:50 UTC (rev 182)
@@ -1,31 +1,33 @@
\name{utilities}
\alias{calc.vars}
-\alias{ecd}
-\alias{get.sampleinfo}
+ \alias{ecd}
+ \alias{get.sampleinfo}
\alias{getKey}
-\alias{getList}
+ \alias{getList}
\alias{gettextZI}
-\alias{getVar}
+ \alias{getVar}
\alias{getDec}
\alias{list.add}
\alias{list.merge}
\alias{list.samples}
-\alias{make.Id}
-\alias{noext}
+ \alias{make.Id}
+ \alias{noext}
\alias{parse.ini}
\alias{Progress}
-\alias{selectFile}
+ \alias{selectFile}
\alias{setKey}
\alias{setwd}
-\alias{trim}
-\alias{underscore2space}
+ \alias{trim}
+ \alias{underscore2space}
\alias{ZIpgm}
\alias{ZIpgmhelp}
\title{ Various utility functions used by ZooImage }
\description{
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/zooimage -r 182
More information about the Zooimage-commits
mailing list