[Dplr-commits] r1110 - in pkg/dplR: . R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Jun 13 10:24:29 CEST 2018
Author: andybunn
Date: 2018-06-13 10:24:28 +0200 (Wed, 13 Jun 2018)
New Revision: 1110
Modified:
pkg/dplR/ChangeLog
pkg/dplR/DESCRIPTION
pkg/dplR/R/detrend.R
pkg/dplR/R/detrend.series.R
pkg/dplR/man/detrend.Rd
pkg/dplR/man/detrend.series.Rd
pkg/dplR/man/wavelet.plot.Rd
Log:
Added option to return curves when detrending.
Modified: pkg/dplR/ChangeLog
===================================================================
--- pkg/dplR/ChangeLog 2018-05-24 06:18:17 UTC (rev 1109)
+++ pkg/dplR/ChangeLog 2018-06-13 08:24:28 UTC (rev 1110)
@@ -1,8 +1,20 @@
* CHANGES IN dplR VERSION 1.6.9
-- None yet.
+File: detrend.series.R and .Rd
+----------------
+- The function will now return the curves used for detrnding the series if return.info is TRUE. Help file ammended.
+File: detrend.R
+----------------
+
+- See above.
+
+File: wavelet.plot.R
+----------------
+
+- Typos.
+
* CHANGES IN dplR VERSION 1.6.8
- Note that Darwin Alexander Pucha Cofrep has been added as a developer to work on plotRings() etc.
Modified: pkg/dplR/DESCRIPTION
===================================================================
--- pkg/dplR/DESCRIPTION 2018-05-24 06:18:17 UTC (rev 1109)
+++ pkg/dplR/DESCRIPTION 2018-06-13 08:24:28 UTC (rev 1110)
@@ -3,7 +3,7 @@
Type: Package
Title: Dendrochronology Program Library in R
Version: 1.6.9
-Date: 2018-05-23
+Date: 2018-06-13
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", "cph", "trl")), person("Franco", "Biondi",
Modified: pkg/dplR/R/detrend.R
===================================================================
--- pkg/dplR/R/detrend.R 2018-05-24 06:18:17 UTC (rev 1109)
+++ pkg/dplR/R/detrend.R 2018-06-13 08:24:28 UTC (rev 1110)
@@ -53,8 +53,9 @@
})
if (return.info) {
- modelStats <- lapply(out, "[[", 2)
- dataStats <- lapply(out, "[[", 3)
+ modelCurves <- lapply(out, "[[", 2)
+ modelStats <- lapply(out, "[[", 3)
+ dataStats <- lapply(out, "[[", 4)
out <- lapply(out, "[[", 1)
}
} else{
@@ -70,8 +71,9 @@
for (i in seq_len(n.series)) {
fits <- do.call(detrend.series, detrend.args)
if (return.info) {
- modelStats[[i]] <- fits[[2]]
- dataStats[[i]] <- fits[[3]]
+ modelCurves[[i]] <- fits[[2]]
+ modelStats[[i]] <- fits[[3]]
+ dataStats[[i]] <- fits[[4]]
fits <- fits[[1]]
}
if (is.data.frame(fits)) {
@@ -85,11 +87,13 @@
if(length(method2) == 1){
out <- data.frame(out, row.names = rn)
names(out) <- y.name
+ modelCurves <- data.frame(modelCurves, row.names = rn)
+ names(modelCurves) <- y.name
}
if (return.info) {
names(modelStats) <- series.names
names(dataStats) <- series.names
- list(series = out, model.info = modelStats, data.info = dataStats)
+ list(series = out, curves = modelCurves, model.info = modelStats, data.info = dataStats)
} else {
out
}
Modified: pkg/dplR/R/detrend.series.R
===================================================================
--- pkg/dplR/R/detrend.series.R 2018-05-24 06:18:17 UTC (rev 1109)
+++ pkg/dplR/R/detrend.series.R 2018-06-13 08:24:28 UTC (rev 1110)
@@ -94,8 +94,9 @@
y2[y2 == 0] <- 0.001
resids <- list()
+ curves <- list()
modelStats <- list()
-
+
if("ModNegExp" %in% method2){
## Nec or lm
nec.func <- function(Y, constrain) {
@@ -224,7 +225,7 @@
format(mneCoefsE)))),
sep = "\n")
}
- mneStats <- list(method = "ModNegExp",
+ mneStats <- list(method = "NegativeExponential",
is.constrained = attr(ModNegExp, "constrained"),
formula = attr(ModNegExp, "formula"),
coefs = mneCoefs)
@@ -232,6 +233,7 @@
mneStats <- NULL
}
resids$ModNegExp <- y2 / ModNegExp
+ curves$ModNegExp <- ModNegExp
modelStats$ModNegExp <- mneStats
do.mne <- TRUE
} else {
@@ -264,7 +266,9 @@
splineStats <- list(method = "Spline", nyrs = nyrs2, f = f)
}
resids$Spline <- y2 / Spline
+ curves$Spline <- Spline
modelStats$Spline <- splineStats
+
do.spline <- TRUE
} else {
do.spline <- FALSE
@@ -282,6 +286,7 @@
}
meanStats <- list(method = "Mean", mean = theMean)
resids$Mean <- y2 / Mean
+ curves$Mean <- Mean
modelStats$Mean <- meanStats
do.mean <- TRUE
} else {
@@ -308,6 +313,7 @@
Ar[Ar<0] <- 0
}
resids$Ar <- Ar / mean(Ar,na.rm=TRUE)
+ curves$Ar <- mean(Ar,na.rm=TRUE)
modelStats$Ar <- arStats
do.ar <- TRUE
} else {
@@ -334,6 +340,7 @@
periodic = FALSE, bass = bass)[["y"]]
}
resids$Friedman <- y2 / Friedman
+ curves$Friedman <- Friedman
modelStats$Friedman <-
list(method = "Friedman",
wt = if (wt.missing) "default" else wt,
@@ -344,6 +351,7 @@
}
resids <- data.frame(resids)
+ curves <- data.frame(curves)
if (verbose || return.info) {
zero.years <- lapply(resids, zeroFun)
n.zeros <- lapply(zero.years, nFun)
@@ -445,14 +453,22 @@
if(!is.null(names(y))) row.names(resids2) <- names(y)
resids2[good.y, ] <- resids
+ curves2 <- matrix(NA, ncol=ncol(curves), nrow=length(y))
+ curves2 <- data.frame(curves2)
+ names(curves2) <- names(curves)
+ if(!is.null(names(y))) row.names(curves2) <- names(y)
+ curves2[good.y, ] <- curves
## Reorder columns of output to match the order of the argument
## "method".
resids2 <- resids2[, method2]
+ curves2 <- curves2[, method2]
## Make sure names (years) are included if there is only one method
if(!is.data.frame(resids2)) names(resids2) <- names(y)
if (return.info) {
list(series = resids2,
- model.info = modelStats[method2], data.info = dataStats)
+ curves = curves2,
+ model.info = modelStats[method2],
+ data.info = dataStats)
} else {
resids2
}
Modified: pkg/dplR/man/detrend.Rd
===================================================================
--- pkg/dplR/man/detrend.Rd 2018-05-24 06:18:17 UTC (rev 1109)
+++ pkg/dplR/man/detrend.Rd 2018-06-13 08:24:28 UTC (rev 1110)
@@ -76,11 +76,13 @@
with the detrended ring widths in each column.
If \code{\var{return.info}} is \code{TRUE}, the return value is a
- \code{list} with three parts:
+ \code{list} with four parts:
\item{series}{ the main result described above (\code{data.frame} or
list of data.frames) }
+ \item{curves}{ the curve or line used to detrend \code{series}. Either a \code{data.frame} or a list of list of data.frames. }
+
\item{model.info}{ Information about the models corresponding to each
output series. A \code{list} with one element for each column of
\code{\var{rwl}}. See \code{\link{detrend.series}} (\sQuote{Value},
Modified: pkg/dplR/man/detrend.series.Rd
===================================================================
--- pkg/dplR/man/detrend.series.Rd 2018-05-24 06:18:17 UTC (rev 1109)
+++ pkg/dplR/man/detrend.series.Rd 2018-06-13 08:24:28 UTC (rev 1110)
@@ -141,11 +141,13 @@
only one method is selected, returns a vector.
If \code{\var{return.info}} is \code{TRUE}, the return value is a
- \code{list} with three parts:
+ \code{list} with four parts:
\item{series}{ the main result described above (\code{data.frame} or
vector) }
+ \item{curves}{ the curve or line used to detrend \code{series}. Either a \code{data.frame} or vector. }
+
\item{model.info}{ Information about the models corresponding to each
output series. Whereas \code{\var{series}} may return a vector,
\code{\var{model.info}} is always a list where each top level
Modified: pkg/dplR/man/wavelet.plot.Rd
===================================================================
--- pkg/dplR/man/wavelet.plot.Rd 2018-05-24 06:18:17 UTC (rev 1109)
+++ pkg/dplR/man/wavelet.plot.Rd 2018-06-13 08:24:28 UTC (rev 1110)
@@ -106,7 +106,8 @@
wavelet.plot(out.wave, useRaster = NA)
# Alternative palette with better separation of colors
# via: rev(RColorBrewer::brewer.pal(10, "Spectral"))
-specCols <- c("#5E4FA2", "#3288BD", "#66C2A5", "#ABDDA4", "#E6F598", "#FEE08B", "#FDAE61", "#F46D43", "#D53E4F", "#9E0142")
+specCols <- c("#5E4FA2", "#3288BD", "#66C2A5", "#ABDDA4", "#E6F598",
+ "#FEE08B", "#FDAE61", "#F46D43", "#D53E4F", "#9E0142")
wavelet.plot(out.wave, key.cols=specCols,useRaster = NA)
# fewer colors
More information about the Dplr-commits
mailing list