[Dplr-commits] r1013 - in pkg/dplR: . R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Mar 2 17:58:03 CET 2016
Author: mvkorpel
Date: 2016-03-02 17:58:02 +0100 (Wed, 02 Mar 2016)
New Revision: 1013
Modified:
pkg/dplR/ChangeLog
pkg/dplR/DESCRIPTION
pkg/dplR/R/detrend.R
pkg/dplR/R/detrend.series.R
pkg/dplR/TODO
pkg/dplR/man/detrend.Rd
pkg/dplR/man/detrend.series.Rd
Log:
Initial implementation of Friedman's super smoother
Modified: pkg/dplR/ChangeLog
===================================================================
--- pkg/dplR/ChangeLog 2016-03-01 21:26:30 UTC (rev 1012)
+++ pkg/dplR/ChangeLog 2016-03-02 16:58:02 UTC (rev 1013)
@@ -34,6 +34,13 @@
--------------------
- wavelet.plot() now passes ... arguments to rasterPlot().
+Files: detrend.R, detrend.series.R
+----------------------------------
+- New detrending method "Friedman" is Friedman's super smoother,
+ implemented in stats::supsmu().
+- When 'return.info' is TRUE, also the "f" parameter of
+ method="Spline" is returned.
+
File: DESCRIPTION
-----------------
- New Suggested package: Cairo. Used (if available) in
Modified: pkg/dplR/DESCRIPTION
===================================================================
--- pkg/dplR/DESCRIPTION 2016-03-01 21:26:30 UTC (rev 1012)
+++ pkg/dplR/DESCRIPTION 2016-03-02 16:58:02 UTC (rev 1013)
@@ -3,7 +3,7 @@
Type: Package
Title: Dendrochronology Program Library in R
Version: 1.6.4
-Date: 2016-03-01
+Date: 2016-03-02
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/detrend.R
===================================================================
--- pkg/dplR/R/detrend.R 2016-03-01 21:26:30 UTC (rev 1012)
+++ pkg/dplR/R/detrend.R 2016-03-02 16:58:02 UTC (rev 1013)
@@ -1,15 +1,16 @@
`detrend` <-
function(rwl, y.name = names(rwl), make.plot = FALSE,
- method=c("Spline", "ModNegExp", "Mean", "Ar"),
+ method=c("Spline", "ModNegExp", "Mean", "Ar", "Friedman"),
nyrs = NULL, f = 0.5, pos.slope = FALSE,
constrain.modnegexp = c("never", "when.fail", "always"),
- verbose = FALSE, return.info = FALSE)
+ verbose = FALSE, return.info = FALSE,
+ wt, span = "cv", bass = 0)
{
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))
- known.methods <- c("Spline", "ModNegExp", "Mean", "Ar")
+ known.methods <- c("Spline", "ModNegExp", "Mean", "Ar", "Friedman")
constrain2 <- match.arg(constrain.modnegexp)
method2 <- match.arg(arg = method,
choices = known.methods,
@@ -18,6 +19,15 @@
stop("'rwl' must be a data.frame")
rn <- row.names(rwl)
+ detrend.args <- c(alist(rwl.i),
+ list(make.plot = FALSE, method = method2,
+ nyrs = nyrs, f = f, pos.slope = pos.slope,
+ constrain.modnegexp = constrain2,
+ verbose = FALSE, return.info = return.info,
+ span = span, bass = bass))
+ if (!missing(wt)) {
+ detrend.args <- c(detrend.args, list(wt = wt))
+ }
if(!make.plot && !verbose &&
("Spline" %in% method2 || "ModNegExp" %in% method2) &&
!inherits(try(suppressWarnings(req.it <-
@@ -39,14 +49,7 @@
.export=exportFun),
{
names(rwl.i) <- rn
- detrend.series(rwl.i, make.plot=FALSE,
- method=method2,
- nyrs=nyrs, f=f,
- pos.slope=pos.slope,
- constrain.modnegexp=
- constrain2,
- verbose=FALSE,
- return.info=return.info)
+ do.call(detrend.series, detrend.args)
})
if (return.info) {
@@ -61,13 +64,11 @@
modelStats <- vector(mode = "list", length = n.series)
dataStats <- vector(mode = "list", length = n.series)
}
+ detrend.args[1] <- alist(rwl[[i]])
+ detrend.args[["verbose"]] <- verbose
+ detrend.args <- c(detrend.args, alist(y.name = y.name[i]))
for (i in seq_len(n.series)) {
- fits <- detrend.series(rwl[[i]], y.name=y.name[i],
- make.plot=make.plot,
- method=method2, nyrs=nyrs, f=f,
- pos.slope=pos.slope,
- constrain.modnegexp=constrain2,
- verbose=verbose, return.info=return.info)
+ fits <- do.call(detrend.series, detrend.args)
if (return.info) {
modelStats[[i]] <- fits[[2]]
dataStats[[i]] <- fits[[3]]
Modified: pkg/dplR/R/detrend.series.R
===================================================================
--- pkg/dplR/R/detrend.series.R 2016-03-01 21:26:30 UTC (rev 1012)
+++ pkg/dplR/R/detrend.series.R 2016-03-02 16:58:02 UTC (rev 1013)
@@ -1,9 +1,10 @@
`detrend.series` <-
function(y, y.name = "", make.plot = TRUE,
- method = c("Spline", "ModNegExp", "Mean", "Ar"),
+ method = c("Spline", "ModNegExp", "Mean", "Ar", "Friedman"),
nyrs = NULL, f = 0.5, pos.slope = FALSE,
constrain.modnegexp = c("never", "when.fail", "always"),
- verbose = FALSE, return.info = FALSE)
+ verbose = FALSE, return.info = FALSE,
+ wt, span = "cv", bass = 0)
{
check.flags(make.plot, pos.slope, verbose, return.info)
if (length(y.name) == 0) {
@@ -12,11 +13,13 @@
y.name2 <- as.character(y.name)[1]
stopifnot(Encoding(y.name2) != "bytes")
}
- known.methods <- c("Spline", "ModNegExp", "Mean", "Ar")
+ known.methods <- c("Spline", "ModNegExp", "Mean", "Ar", "Friedman")
constrain2 <- match.arg(constrain.modnegexp)
method2 <- match.arg(arg = method,
choices = known.methods,
several.ok = TRUE)
+ wt.missing <- missing(wt)
+ wt.description <- NULL
if (verbose) {
widthOpt <- getOption("width")
indentSize <- 1
@@ -28,6 +31,7 @@
collapse = ""))
cat(gettext("Verbose output: ", domain="R-dplR"), y.name2, "\n",
sep = "")
+ wt.description <- if (wt.missing) "default" else deparse(wt)
opts <- c("make.plot" = make.plot,
"method(s)" = deparse(method2),
"nyrs" = if (is.null(nyrs)) "NULL" else nyrs,
@@ -35,7 +39,10 @@
"pos.slope" = pos.slope,
"constrain.modnegexp" = constrain2,
"verbose" = verbose,
- "return.info" = return.info)
+ "return.info" = return.info,
+ "wt" = wt.description,
+ "span" = span,
+ "bass" = bass)
optNames <- names(opts)
optChar <- c(gettext("Options", domain="R-dplR"),
paste(str_pad(optNames,
@@ -254,7 +261,7 @@
Spline <- rep.int(theMean, nY2)
splineStats <- list(method = "Mean", mean = theMean)
} else {
- splineStats <- list(method = "Spline", nyrs = nyrs2)
+ splineStats <- list(method = "Spline", nyrs = nyrs2, f = f)
}
resids$Spline <- y2 / Spline
modelStats$Spline <- splineStats
@@ -307,6 +314,35 @@
do.ar <- FALSE
}
+ if ("Friedman" %in% method2) {
+ if (is.null(wt.description)) {
+ wt.description <- if (wt.missing) "default" else deparse(wt)
+ }
+ if (verbose) {
+ cat("", sepLine, sep = "\n")
+ cat(indent(c(gettext(c("Detrend by FriedMan's super smoother.",
+ "Smoother parameters"), domain = "R-dplR"),
+ paste0("span = ", span, ", bass = ", bass),
+ paste0("wt = ", wt.description))),
+ sep = "\n")
+ }
+ if (wt.missing) {
+ Friedman <- supsmu(x = seq_len(nY2), y = y2, span = span,
+ periodic = FALSE, bass = bass)[["y"]]
+ } else {
+ Friedman <- supsmu(x = seq_len(nY2), y = y2, wt = wt, span = span,
+ periodic = FALSE, bass = bass)[["y"]]
+ }
+ resids$Friedman <- y2 / Friedman
+ modelStats$Friedman <-
+ list(method = "Friedman",
+ wt = if (wt.missing) "default" else wt,
+ span = span, bass = bass)
+ do.friedman <- TRUE
+ } else {
+ do.friedman <- FALSE
+ }
+
resids <- data.frame(resids)
if (verbose || return.info) {
zero.years <- lapply(resids, zeroFun)
@@ -337,13 +373,18 @@
if(make.plot){
op <- par(no.readonly=TRUE)
on.exit(par(op))
+ n.methods <- ncol(resids)
par(mar=c(2.1, 2.1, 2.1, 2.1), mgp=c(1.1, 0.1, 0),
tcl=0.5, xaxs='i')
- mat <- switch(ncol(resids),
+ if (n.methods > 4) {
+ par(cex.main = min(1, par("cex.main")))
+ }
+ mat <- switch(n.methods,
matrix(c(1,2), nrow=2, ncol=1, byrow=TRUE),
matrix(c(1,1,2,3), nrow=2, ncol=2, byrow=TRUE),
matrix(c(1,2,3,4), nrow=2, ncol=2, byrow=TRUE),
- matrix(c(1,1,2,3,4,5), nrow=3, ncol=2, byrow=TRUE))
+ matrix(c(1,1,2,3,4,5), nrow=3, ncol=2, byrow=TRUE),
+ matrix(c(1,1,1,2,3,4,5,6,0), nrow=3, ncol=3, byrow=TRUE))
layout(mat,
widths=rep.int(0.5, ncol(mat)),
heights=rep.int(1, nrow(mat)))
@@ -354,6 +395,7 @@
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)
+ if(do.friedman) lines(Friedman, col="cyan", lwd=2)
if(do.spline){
plot(resids$Spline, type="l", col="green",
@@ -387,6 +429,14 @@
abline(h=1)
mtext(text="(Not plotted with raw series)",side=3,line=-1,cex=0.75)
}
+
+ if (do.friedman) {
+ plot(resids$Friedman, type="l", col="cyan",
+ main=gettext("Friedman's Super Smoother", domain="R-dplR"),
+ xlab=gettext("Age (Yrs)", domain="R-dplR"),
+ ylab=gettext("RWI", domain="R-dplR"))
+ abline(h=1)
+ }
}
resids2 <- matrix(NA, ncol=ncol(resids), nrow=length(y))
Modified: pkg/dplR/TODO
===================================================================
--- pkg/dplR/TODO 2016-03-01 21:26:30 UTC (rev 1012)
+++ pkg/dplR/TODO 2016-03-02 16:58:02 UTC (rev 1013)
@@ -1,10 +1,10 @@
-o[andybunn] Add Friedman super-smoother to detrend.series and its ilk. This
+o [andybunn] Add Friedman super-smoother to detrend.series and its ilk. This
should be trivial using function supsmu() in stats. But it will
require some work on the docs, plotting, etc.
-o[andybunn] Recode vignettes into markdown so as to have them on Rpubs?
+o [andybunn] Recode vignettes into markdown so as to have them on Rpubs?
-o[mvkorpel] Add option for smooth CI curves from theoretical AR1 in redfit!
+o [mvkorpel] Add option for smooth CI curves from theoretical AR1 in redfit!
* At the moment, in the crossdating functions where a user wants to compare a
series to a master chrnology we calculate the master from a rwl object.
@@ -20,7 +20,7 @@
and Treydte, K.S. 2001 A new parameter to evaluate temporal signal
strength of tree-ring chronologies. Dendrochronologia, 19 (1), 93-102.
-o[andybunn] xskel.cff.plot is a renamed version of skel.cff.plot which has been taken
+o [andybunn] xskel.cff.plot is a renamed version of skel.cff.plot which has been taken
out of the package. I think. The x preface is to denote its use
in crossdating. This function needs to have checks built in that will allow
it to be used on rwl and crn objects (for the master).
@@ -28,20 +28,28 @@
its own function called xskel.calc in helpers.R
_ I will make a version without the ccf plots as well "xskel.plot."
-o[mvkorpel] Finish the verbose option for detrend.series and it's bretheren
+o [mvkorpel] Finish the verbose option for detrend.series and it's bretheren
(e.g., detrend, i.detrend.series, i.detrend). Better yet, should we
depricate the i.detrend functions and have "interactive" be an argument
to detrend?
-o[mvkorpel] Should we use class('rwl) as a way of error checking?
+o [mvkorpel] Should we use class('rwl) as a way of error checking?
E.g.,when a function has "rwl" as an argument should there be a check:
if (!inherits(rwl, "rwl")) {
stop('use only with "rwl" objects')
- Related: We should have functions is.rwl() and as.rwl()
-o[andybunn] Write more vignettes:
+o [andybunn] Write more vignettes:
- Advanced chronology building (strip.rwl, etc.)
+o [mvkorpel] Investigate parallel processing in detrend
+- Is it actually any good or is the overhead too large?
+- It is possible that the relative benefit of parallel processing has
+ changed over time.
+- Different parallel backends have different performance characteristics.
+
+- The logic of when to go parallel is a heuristic that can be adjusted.
+
Modified: pkg/dplR/man/detrend.Rd
===================================================================
--- pkg/dplR/man/detrend.Rd 2016-03-01 21:26:30 UTC (rev 1012)
+++ pkg/dplR/man/detrend.Rd 2016-03-02 16:58:02 UTC (rev 1013)
@@ -8,10 +8,11 @@
}
\usage{
detrend(rwl, y.name = names(rwl), make.plot = FALSE,
- method = c("Spline", "ModNegExp", "Mean", "Ar"), nyrs = NULL,
- f = 0.5, pos.slope = FALSE,
+ method = c("Spline", "ModNegExp", "Mean", "Ar", "Friedman"),
+ nyrs = NULL, f = 0.5, pos.slope = FALSE,
constrain.modnegexp = c("never", "when.fail", "always"),
- verbose = FALSE, return.info = FALSE)
+ verbose = FALSE, return.info = FALSE,
+ wt, span = "cv", bass = 0)
}
\arguments{
@@ -51,6 +52,15 @@
about models and data will be added to the return value. See
\sQuote{Value}. }
+ \item{wt}{ a \code{numeric} vector of case weights for method
+ \code{"Friedman"}. The default means equals weights. }
+
+ \item{span}{ a \code{numeric} value controlling method
+ \code{"Friedman"}, or \code{"cv"} (default) for automatic choice by
+ cross-validation. See \code{\link{supsmu}}. }
+
+ \item{bass}{ a \code{numeric} value controlling the smoothness of the
+ fitted curve in method \code{"Friedman"}. See \code{\link{supsmu}}. }
}
\details{
See \code{\link{detrend.series}} for details on detrending
Modified: pkg/dplR/man/detrend.series.Rd
===================================================================
--- pkg/dplR/man/detrend.series.Rd 2016-03-01 21:26:30 UTC (rev 1012)
+++ pkg/dplR/man/detrend.series.Rd 2016-03-02 16:58:02 UTC (rev 1013)
@@ -8,10 +8,11 @@
}
\usage{
detrend.series(y, y.name = "", make.plot = TRUE,
- method = c("Spline", "ModNegExp", "Mean", "Ar"),
+ method = c("Spline", "ModNegExp", "Mean", "Ar", "Friedman"),
nyrs = NULL, f = 0.5, pos.slope = FALSE,
constrain.modnegexp = c("never", "when.fail", "always"),
- verbose=FALSE, return.info=FALSE)
+ verbose = FALSE, return.info = FALSE,
+ wt, span = "cv", bass = 0)
}
\arguments{
@@ -55,6 +56,16 @@
about models and data will be added to the return value. See
\sQuote{Value}. }
+ \item{wt}{ a \code{numeric} vector of case weights for method
+ \code{"Friedman"}. The default means equals weights. }
+
+ \item{span}{ a \code{numeric} value controlling method
+ \code{"Friedman"}, or \code{"cv"} (default) for automatic choice by
+ cross-validation. See \code{\link{supsmu}}. }
+
+ \item{bass}{ a \code{numeric} value controlling the smoothness of the
+ fitted curve in method \code{"Friedman"}. See \code{\link{supsmu}}. }
+
}
\details{
This detrends and standardizes a tree-ring series. The detrending is
@@ -114,6 +125,12 @@
user to determine the best detrending method for their data.
See the references below for further details on detrending.
+
+ The \code{"Friedman"} approach uses Friedman's \sQuote{super smoother}
+ as implemented in \code{\link{supsmu}}. The parameters
+ \code{\var{wt}}, \code{\var{span}} and \code{\var{bass}} can be
+ adjusted, but \code{\var{periodic}} is always set to \code{FALSE}.
+
}
\value{
More information about the Dplr-commits
mailing list