[Dplr-commits] r983 - in pkg/dplR: . R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed May 6 17:16:05 CEST 2015
Author: mvkorpel
Date: 2015-05-06 17:16:05 +0200 (Wed, 06 May 2015)
New Revision: 983
Modified:
pkg/dplR/ChangeLog
pkg/dplR/DESCRIPTION
pkg/dplR/R/chron.R
pkg/dplR/R/detrend.series.R
pkg/dplR/R/read.ids.R
pkg/dplR/R/skel.plot.R
pkg/dplR/R/write.compact.R
pkg/dplR/R/write.crn.R
pkg/dplR/R/write.tridas.R
pkg/dplR/R/write.tucson.R
Log:
Improved (string) argument handling and checking in many functions.
Modified: pkg/dplR/ChangeLog
===================================================================
--- pkg/dplR/ChangeLog 2015-05-04 11:52:37 UTC (rev 982)
+++ pkg/dplR/ChangeLog 2015-05-06 15:16:05 UTC (rev 983)
@@ -52,6 +52,15 @@
to speed up some operations on rows or columns of matrices.
- Reduced the number of calls to options() by one when setting and
restoring options
+- Argument values, particularly those that should be character
+ vectors, are checked more thoroughly. This makes many functions
+ more robust against unusual values: wrong type, "bytes" encoding,
+ zero length or NA. Some values that previously failed are now
+ silently accepted by coercion to character, extraction of first
+ element when a single string is expected, and / or intepretation
+ of a zero length argument as an empty string. NA is equivalent to
+ "NA" in detrend.series() and skel.plot() where it is used for
+ plotting or text output, but forbidden otherwise, e.g. in chron().
File: ffcsaps.R
---------------
@@ -62,10 +71,6 @@
File: helpers.R
---------------
-- Internal function fix.names() now checks its 'mapping.fname'
- argument more thoroughly. This makes write.compact() and
- write.tucson() more robust against unusual values of that
- argument: wrong type, "bytes" encoding, zero length or NA.
- Internal function vecMatched does not care if nzchar() starts
returning NA some day.
@@ -113,6 +118,11 @@
attached. The solution is to extract the coefficients of the model
and use those in the call.
+File: write.crn.R
+-----------------
+
+- Better coding style: avoid using assign().
+
File: write.tridas.R
--------------------
Modified: pkg/dplR/DESCRIPTION
===================================================================
--- pkg/dplR/DESCRIPTION 2015-05-04 11:52:37 UTC (rev 982)
+++ pkg/dplR/DESCRIPTION 2015-05-06 15:16:05 UTC (rev 983)
@@ -3,7 +3,7 @@
Type: Package
Title: Dendrochronology Program Library in R
Version: 1.6.3
-Date: 2015-05-04
+Date: 2015-05-06
Authors at R: c(person("Andy", "Bunn", role = c("aut", "cph",
"cre", "trl"), email = "andy.bunn at wwu.edu"), person("Mikko",
"Korpela", role = c("aut", "trl")), person("Franco", "Biondi",
Modified: pkg/dplR/R/chron.R
===================================================================
--- pkg/dplR/R/chron.R 2015-05-04 11:52:37 UTC (rev 982)
+++ pkg/dplR/R/chron.R 2015-05-06 15:16:05 UTC (rev 983)
@@ -1,9 +1,15 @@
`chron` <-
function(x, prefix="xxx", biweight=TRUE, prewhiten=FALSE, ...)
{
- prefix.str <- as.character(prefix)
- if (length(prefix.str) != 1 || nchar(prefix.str) > 3) {
- stop("'prefix' must be a character string with less than 4 characters")
+ check.flags(biweight, prewhiten)
+ if (length(prefix) == 0) {
+ prefix.str <- ""
+ } else {
+ prefix.str <- as.character(prefix)[1]
+ if (is.na(prefix.str) || Encoding(prefix.str) == "bytes" ||
+ nchar(prefix.str) > 3) {
+ stop("'prefix' must be a character string with less than 4 characters")
+ }
}
samps <- rowSums(!is.na(x))
if (!biweight) {
Modified: pkg/dplR/R/detrend.series.R
===================================================================
--- pkg/dplR/R/detrend.series.R 2015-05-04 11:52:37 UTC (rev 982)
+++ pkg/dplR/R/detrend.series.R 2015-05-06 15:16:05 UTC (rev 983)
@@ -5,10 +5,13 @@
constrain.modnegexp = c("never", "when.fail", "always"),
verbose = FALSE, return.info = FALSE)
{
- stopifnot(identical(make.plot, TRUE) || identical(make.plot, FALSE),
- identical(pos.slope, FALSE) || identical(pos.slope, TRUE),
- identical(verbose, TRUE) || identical(verbose, FALSE),
- identical(return.info, TRUE) || identical(return.info, FALSE))
+ check.flags(make.plot, pos.slope, verbose, return.info)
+ if (length(y.name) == 0) {
+ y.name2 <- ""
+ } else {
+ y.name2 <- as.character(y.name)[1]
+ stopifnot(Encoding(y.name2) != "bytes")
+ }
known.methods <- c("Spline", "ModNegExp", "Mean", "Ar")
constrain2 <- match.arg(constrain.modnegexp)
method2 <- match.arg(arg = method,
@@ -23,7 +26,7 @@
sepLine <-
indent(paste0(rep.int("~", max(1, widthOpt - 2 * indentSize)),
collapse = ""))
- cat(gettext("Verbose output: ", domain="R-dplR"), y.name, "\n",
+ cat(gettext("Verbose output: ", domain="R-dplR"), y.name2, "\n",
sep = "")
opts <- c("make.plot" = make.plot,
"method(s)" = deparse(method2),
@@ -347,7 +350,7 @@
plot(y2, type="l", ylab="mm",
xlab=gettext("Age (Yrs)", domain="R-dplR"),
- main=gettextf("Raw Series %s", y.name, domain="R-dplR"))
+ main=gettextf("Raw Series %s", y.name2, domain="R-dplR"))
if(do.spline) lines(Spline, col="green", lwd=2)
if(do.mne) lines(ModNegExp, col="red", lwd=2)
if(do.mean) lines(Mean, col="blue", lwd=2)
Modified: pkg/dplR/R/read.ids.R
===================================================================
--- pkg/dplR/R/read.ids.R 2015-05-04 11:52:37 UTC (rev 982)
+++ pkg/dplR/R/read.ids.R 2015-05-06 15:16:05 UTC (rev 983)
@@ -9,6 +9,12 @@
typo.ratio = 5, use.cor = TRUE) {
### Check arguments
+ stopifnot(is.data.frame(rwl))
+ ids <- names(rwl)
+ if (is.null(ids) || any(is.na(ids))) {
+ stop("'rwl' must have non-NA names")
+ }
+ stopifnot(Encoding(ids) != "bytes")
check.flags(fix.typos, use.cor, ignore.site.case)
if (fix.typos) {
stopifnot(is.numeric(typo.ratio), length(typo.ratio) == 1,
@@ -691,11 +697,7 @@
dupl=n.duplicated)
}
### Actual body of the main function
- ids <- names(rwl)
n.cases <- length(ids)
- if (is.null(ids) || any(is.na(ids))) {
- stop("'rwl' must have non-NA names")
- }
if (n.cases < 2) {
return(data.frame(tree = seq_len(n.cases), core = rep(1, n.cases),
row.names = ids))
Modified: pkg/dplR/R/skel.plot.R
===================================================================
--- pkg/dplR/R/skel.plot.R 2015-05-04 11:52:37 UTC (rev 982)
+++ pkg/dplR/R/skel.plot.R 2015-05-06 15:16:05 UTC (rev 983)
@@ -2,8 +2,16 @@
function(rw.vec, yr.vec = NULL, sname = "", filt.weight = 9,
dat.out = FALSE, master=FALSE, plot=TRUE)
{
- if(nchar(sname) > 7)
- stop("'sname' must be a character string less than 8 characters long")
+ if (length(sname) == 0) {
+ sname2 <- ""
+ } else {
+ sname2 <- as.character(sname)[1]
+ if (is.na(sname2)) {
+ sname2 <- "NA"
+ } else if (Encoding(sname2) == "bytes" || nchar(sname2) > 7) {
+ stop("'sname' must be a character string less than 8 characters long")
+ }
+ }
## what about NA. Internal NA?
na.mask <- is.na(rw.vec)
@@ -200,12 +208,12 @@
grid.lines(x=unit(c(start.mm, start.mm), "mm"),
y=unit(c(rh, 0), "mm"),
gp = gpar(lwd = 2, lineend = "square", linejoin = "round"))
- fontsize.sname <- ifelse(nchar(sname) > 6, 9, 10)
+ fontsize.sname <- ifelse(nchar(sname2) > 6, 9, 10)
grid.polygon(x = c(start.mm, start.mm, start.mm - 2),
y = yy1, default.units = "mm",
gp=gpar(fill = "black", lineend = "square",
linejoin = "round"))
- grid.text(label = sname, x = start.mm - 1, y = yy2,
+ grid.text(label = sname2, x = start.mm - 1, y = yy2,
just = sjust, rot = 90, default.units = "mm",
gp = gpar(fontsize=fontsize.sname))
popViewport()
Modified: pkg/dplR/R/write.compact.R
===================================================================
--- pkg/dplR/R/write.compact.R 2015-05-04 11:52:37 UTC (rev 982)
+++ pkg/dplR/R/write.compact.R 2015-05-06 15:16:05 UTC (rev 983)
@@ -25,7 +25,10 @@
name.width <-
line.width - max.field.width.width - max.n.width - max.i.width - 17
- col.names <- fix.names(x=names(rwl.df), limit=name.width,
+ col.names <- names(rwl.df)
+ stopifnot(is.character(col.names), !is.na(col.names),
+ Encoding(col.names) != "bytes")
+ col.names <- fix.names(x=col.names, limit=name.width,
mapping.fname=mapping.fname,
mapping.append=mapping.append, basic.charset=TRUE)
Modified: pkg/dplR/R/write.crn.R
===================================================================
--- pkg/dplR/R/write.crn.R 2015-05-04 11:52:37 UTC (rev 982)
+++ pkg/dplR/R/write.crn.R 2015-05-06 15:16:05 UTC (rev 983)
@@ -1,8 +1,12 @@
`write.crn` <- function(crn, fname, header=NULL, append=FALSE)
{
+ stopifnot(is.data.frame(crn))
if (ncol(crn) != 2) {
stop("'crn' must have 2 columns")
}
+ cnames <- names(crn)
+ stopifnot(is.character(cnames), !is.na(cnames),
+ Encoding(cnames) != "bytes")
crn2 <- crn
if (any(is.na(crn2))) {
@@ -20,16 +24,15 @@
stop("bad idea to append with 'header'")
}
}
- header2 <- header
- if(length(header2) > 0){
- if (!is.list(header2)) {
+ if (length(header) > 0){
+ if (!is.list(header)) {
stop("header must be a list")
}
header.names <-
c("site.id", "site.name", "spp.code", "state.country",
"spp", "elev", "lat", "long", "first.yr", "last.yr",
"lead.invs", "comp.date")
- if (!all(header.names %in% names(header2))) {
+ if (!all(header.names %in% names(header))) {
stop("'header' must be a list with the following names: ",
paste(dQuote(header.names), collapse = ", "))
}
@@ -40,20 +43,15 @@
## Note: lat-lons are in degrees and minutes, ddmm or dddmm
## Record #3: 1-6 Site ID, 10-72 Lead Investigator, 73-80
## comp. date
- header2 <- lapply(header2, as.character)
- site.id <- header2$site.id[1]
- site.name <- header2$site.name[1]
- spp.code <- header2$spp.code[1]
- state.country <- header2$state.country[1]
- spp <- header2$spp[1]
- elev <- header2$elev[1]
- lat <- header2$lat[1]
- long <- header2$long[1]
- lead.invs <- header2$lead.invs[1]
- comp.date <- header2$comp.date[1]
- lat.long <- ifelse(nchar(long) > 5, paste0(lat, long),
- paste(lat, long, sep=" "))
- yrs <- paste(header2$first.yr[1], header2$last.yr[1], sep=" ")
+ header2 <- vapply(lapply(header, as.character), "[", character(1), 1)
+ stopifnot(!is.na(header2), Encoding(header2) != "bytes")
+ header2["lat.long"] <- if (nchar(header2["long"]) > 5) {
+ paste0(header2["lat"], header2["long"])
+ } else {
+ paste(header2["lat"], header2["long"], sep=" ")
+ }
+ header2["yrs"] <-
+ paste(header2["first.yr"], header2["last.yr"], sep=" ")
field.name <-
c("site.id", "site.name", "spp.code", "state.country", "spp",
@@ -62,19 +60,23 @@
for (i in seq_along(field.name)) {
this.name <- field.name[i]
this.width <- field.width[i]
- this.var <- get(this.name)
+ this.var <- header2[this.name]
this.nchar <- nchar(this.var)
if (this.nchar > this.width) {
- assign(this.name, substr(this.var, 1, this.width))
+ header2[this.name] <- substr(this.var, 1, this.width)
} else if (this.nchar < this.width) {
- assign(this.name, encodeString(this.var, width = this.width))
+ header2[this.name] <-
+ encodeString(this.var, width = this.width)
}
}
- hdr1 <- paste0(site.id, " ", site.name, spp.code)
- hdr2 <- paste0(site.id, " ", state.country, spp, elev, " ",
- lat.long, " ", yrs)
- hdr3 <- paste0(site.id, " ", lead.invs, comp.date)
+ hdr1 <- paste0(header2["site.id"], " ", header2["site.name"],
+ header2["spp.code"])
+ hdr2 <- paste0(header2["site.id"], " ", header2["state.country"],
+ header2["spp"], header2["elev"], " ",
+ header2["lat.long"], " ", header2["yrs"])
+ hdr3 <- paste0(header2["site.id"], " ", header2["lead.invs"],
+ header2["comp.date"])
hdr <- c(hdr1, hdr2, hdr3)
}
@@ -83,7 +85,7 @@
decades <- unique(decades.vec)
n.decades <- length(decades)
## 1-6
- crn.name <- names(crn2)[1]
+ crn.name <- cnames[1]
crn.width <- nchar(crn.name)
## If crn.width > 6, truncate
if (crn.width > 6) {
@@ -125,7 +127,7 @@
## Finish last decade with 9990 as NA and 0 as samp depth.
dec.str[i] <- paste0(dec.str[i],
paste(rep("9990 0", 10-n.yrs), collapse=""))
- if (length(header2) > 0) {
+ if (length(header) > 0) {
dec.str <- c(hdr, dec.str)
}
cat(dec.str, file = fname, sep = "\n", append=append)
Modified: pkg/dplR/R/write.tridas.R
===================================================================
--- pkg/dplR/R/write.tridas.R 2015-05-04 11:52:37 UTC (rev 982)
+++ pkg/dplR/R/write.tridas.R 2015-05-06 15:16:05 UTC (rev 983)
@@ -457,6 +457,8 @@
c("site.info", "", "title")))
n.col <- ncol(rwl.df)
cnames <- names(rwl.df)
+ stopifnot(is.character(cnames), !is.na(cnames),
+ Encoding(cnames) != "bytes")
## If 'ids' is NULL then assume one core, radius and
## measurement per tree. In case of missing columns (less
Modified: pkg/dplR/R/write.tucson.R
===================================================================
--- pkg/dplR/R/write.tucson.R 2015-05-04 11:52:37 UTC (rev 982)
+++ pkg/dplR/R/write.tucson.R 2015-05-06 15:16:05 UTC (rev 983)
@@ -80,6 +80,8 @@
nseries <- ncol(rwl.df)
yrs.all <- as.numeric(row.names(rwl.df))
col.names <- names(rwl.df)
+ stopifnot(is.character(col.names), !is.na(col.names),
+ Encoding(col.names) != "bytes")
## Sort years using increasing order, reorder rwl.df accordingly
yrs.order <- sort.list(yrs.all)
More information about the Dplr-commits
mailing list