# optionsTable.R
# a set of routines to query user-settable options
`readOptionsTable` <- function( file="Options.txt") {
tbl <- read.delim( file, as.is=TRUE, colClasses="character")
if ( ncol(tbl) < 2) stop( paste( "Invalid options table: expected 2 columns: got", ncol(tbl)))
colnames(tbl)[1:2] <- c("OptionName", "Value")
# quick check for invalid non-tab separators
blanksInNames <- grep( " +", tbl$OptionName)
if ( length( blanksInNames)) {
cat( "\nWarning: Options Table may have non-tab separators.")
cat( "\n Check: ", tbl$OptionName[ blanksInNames], "\n")
}
return( tbl)
}
# get the value of one option as a charater string
`getOptionValue` <- function( tbl, arg, speciesID=NULL, notfound=NA, verbose=TRUE) {
# send back default if no option file exists
if ( ! is.na(notfound) && is.character(tbl) && ! file.exists(tbl[1])) return( notfound)
if ( typeof( tbl) != "list") {
try( tbl <- readOptionsTable( tbl))
}
if ( ! all( colnames(tbl)[1:2] == c("OptionName", "Value"))) stop( "Not a valid options table")
# allow the arg to be almost anything, character string, object name, etc...
bigWidth <- max( base::nchar( tbl$OptionName))
bigWidth <- min( bigWidth, 24)
name <- try( base::eval( arg), silent=TRUE)
if ( class(name) == "try-error") {
name <- as.character( substitute( arg));
}
# find that argument, with posibility of a speciesID suffix
row <- base::match( name, tbl$OptionName, nomatch=0)
if ( !is.null( speciesID)) {
name2 <- paste( name, speciesID, sep=".")
row2 <- base::match( name2, tbl$OptionName, nomatch=0)
if ( row2 > 0) {
row <- row2
name <- name2
bigWidth <- max( bigWidth, nchar(name2))
}
}
if (verbose) cat( "\nOption Value: \t", format( name, width=bigWidth), sep="")
if ( is.na( notfound) && (row == 0)) {
stop( paste( "Required 'OptionsTable' entry not found: looked for: ", name))
}
if ( row > 0) {
out <- tbl$Value[ row]
# allow environment variables in the value field...
out <- env.sub( out)
if (verbose) cat( "\tFound:\t", out)
} else {
# when not found, see if it is 'almost' a match, e.g. a misspelling
editDist <- adist( name, tbl$OptionName)
closeEnough <- max( 3, round(nchar(name)*0.25))
if ( any( editDist <= closeEnough)) {
cat( "\n\nWarning: wanted Option entry: ", name,
" is a close but inexact match to some Option names.\n Using 'default' value instead...\n")
}
out <- notfound
if (verbose) cat( "\tDefault:\t", out)
}
return( out)
}
# get the value of one option as a boolean True/False
`getOptionTrue` <- function( tbl, arg, speciesID=NULL, notfound=NA, verbose=TRUE) {
if ( typeof( tbl) != "list") {
try( tbl <- readOptionsTable( tbl))
}
if ( ! all( colnames(tbl)[1:2] == c("OptionName", "Value"))) stop( "Not a valid options table")
# allow the arg to be almost anything
bigWidth <- max( base::nchar( tbl$OptionName))
bigWidth <- min( bigWidth, 24)
name <- try( base::eval( arg), silent=TRUE)
if ( class(name) == "try-error") {
name <- as.character( substitute( arg));
}
# find that argument, with posibility of a speciesID suffix
row <- base::match( name, tbl$OptionName, nomatch=0)
if ( !is.null( speciesID)) {
name2 <- paste( name, speciesID, sep=".")
row2 <- base::match( name2, tbl$OptionName, nomatch=0)
if ( row2 > 0) {
row <- row2
name <- name2
bigWidth <- max( bigWidth, nchar(name2))
}
}
if (verbose) cat( "\nOption True: \t", format( name, width=bigWidth), sep="")
if ( is.na( notfound) && (row == 0)) {
stop( paste( "Required 'OptionsTable' entry not found: looked for: ", name))
}
if ( ! is.na( notfound)) {
if ( typeof( notfound) != "logical") stop( "Error: getOptionTrue expects logical 'notfound' arg.")
}
if ( row > 0) {
out <- tbl$Value[ row]
# allow environment variables in the value field...
out <- env.sub( out)
out <- as.TRUEorFALSE( out)
if (verbose) cat( "\tFound: \t", out)
} else {
# when not found, see if it is 'almost' a match, e.g. a misspelling
editDist <- adist( name, tbl$OptionName)
closeEnough <- max( 3, round(nchar(name)*0.25))
if ( any( editDist <= closeEnough)) {
cat( "\n\nWarning: wanted Option entry: ", name,
" is a close but inexact match to some Option names.\n Using 'default' value instead...\n")
}
out <- notfound
if (verbose) cat( "\tDefault:\t", out)
}
return( out)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.