[Dplr-commits] r1119 - in pkg/dplR: . R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Jun 20 22:12:40 CEST 2018
Author: andybunn
Date: 2018-06-20 22:12:39 +0200 (Wed, 20 Jun 2018)
New Revision: 1119
Added:
pkg/dplR/R/as.rwl.R
pkg/dplR/man/as.rwl.Rd
Modified:
pkg/dplR/ChangeLog
pkg/dplR/NAMESPACE
pkg/dplR/R/crn.plot.R
pkg/dplR/R/detrend.R
pkg/dplR/R/detrend.series.R
pkg/dplR/R/pass.filt.R
pkg/dplR/R/spag.plot.R
pkg/dplR/man/crn.plot.Rd
pkg/dplR/man/detrend.Rd
pkg/dplR/man/detrend.series.Rd
pkg/dplR/man/pass.filt.Rd
pkg/dplR/man/spag.plot.Rd
Log:
Chenges big and small. See ChangeLog. New function as.rwl() which is still just a sketch. Added difference as an option to detrend. Bug fixes.
Modified: pkg/dplR/ChangeLog
===================================================================
--- pkg/dplR/ChangeLog 2018-06-19 01:23:42 UTC (rev 1118)
+++ pkg/dplR/ChangeLog 2018-06-20 20:12:39 UTC (rev 1119)
@@ -1,5 +1,25 @@
* CHANGES IN dplR VERSION 1.6.9
+File: spag.plot.R and .Rd
+----------------
+
+- Small bug fix
+
+File: crn.plot.R and .Rd
+----------------
+
+- Small bug fix
+
+File: as.rwl.R and .Rd
+----------------
+
+- Adding a convenience function to transform data.frame or matrix to class rwl
+
+File: powt.R and .Rd
+----------------
+
+- Small change so that powt returns class rwl as well as data.frame
+
File: pass.filt.R and .Rd
----------------
@@ -16,8 +36,9 @@
- The function will now return the curves used for detrnding the series if return.info is TRUE. Help file ammended.
-- Added the Hughershoff curve as an method for detrending. It's done along the lines of ModNegExp with straight line if the nls call fais.
+- Added the Hughershoff curve as an method for detrending. It's done along the lines of ModNegExp with straight line if the nls call fails.
+- Added option to compute differences via subtraction rather than division.
File: detrend.R
----------------
Modified: pkg/dplR/NAMESPACE
===================================================================
--- pkg/dplR/NAMESPACE 2018-06-19 01:23:42 UTC (rev 1118)
+++ pkg/dplR/NAMESPACE 2018-06-20 20:12:39 UTC (rev 1119)
@@ -55,7 +55,7 @@
write.tucson, plot.rwl, interseries.cor, summary.rwl, plot.crn,
insert.ring, delete.ring, xskel.ccf.plot, xskel.plot, latexify,
latexDate, rasterPlot, treeMean, rwl.report, print.rwl.report,
- plotRings,time.rwl,time.crn,csv2rwl,pass.filt)
+ plotRings,time.rwl,time.crn,csv2rwl,pass.filt,as.rwl)
S3method(print, redfit)
S3method(plot, rwl)
Added: pkg/dplR/R/as.rwl.R
===================================================================
--- pkg/dplR/R/as.rwl.R (rev 0)
+++ pkg/dplR/R/as.rwl.R 2018-06-20 20:12:39 UTC (rev 1119)
@@ -0,0 +1,14 @@
+as.rwl <- function(x){
+ if(!(class(x) == "data.frame" | class(x) == "matrix")) {
+ stop("x must be a data.frame or matrix")
+ }
+ if(class(x) == "matrix") {
+ x <- as.data.frame(x)
+ }
+ # are rownames the time vector?
+ tmTest <- all(diff(as.numeric(row.names(x))) == 1)
+ if(!tmTest) stop("x must have time (years) in the rownames so that all(diff(as.numeric(row.names(x))) == 1)")
+ if("rwl" %in% class(x)) TRUE
+ class(x) <- c("rwl", "data.frame")
+ x
+}
Property changes on: pkg/dplR/R/as.rwl.R
___________________________________________________________________
Added: svn:eol-style
+ native
Modified: pkg/dplR/R/crn.plot.R
===================================================================
--- pkg/dplR/R/crn.plot.R 2018-06-19 01:23:42 UTC (rev 1118)
+++ pkg/dplR/R/crn.plot.R 2018-06-20 20:12:39 UTC (rev 1119)
@@ -10,8 +10,9 @@
abline.lty=1, abline.lwd=1,
xlab="Time",ylab="RWI",
...) {
- if(!is.data.frame(crn)) stop("'crn' must be a data.frame")
-
+ #if(!is.data.frame(crn)) stop("'crn' must be a data.frame")
+ if(!("crn" %in% class(crn))) stop("'crn' must be class crn")
+
op <- par(no.readonly=TRUE) # Save par
on.exit(par(op)) # Reset par on exit
par(mar=c(3, 3, 3, 3), mgp=c(1.1, 0.1, 0),
Modified: pkg/dplR/R/detrend.R
===================================================================
--- pkg/dplR/R/detrend.R 2018-06-19 01:23:42 UTC (rev 1118)
+++ pkg/dplR/R/detrend.R 2018-06-20 20:12:39 UTC (rev 1119)
@@ -4,7 +4,7 @@
nyrs = NULL, f = 0.5, pos.slope = FALSE,
constrain.nls = c("never", "when.fail", "always"),
verbose = FALSE, return.info = FALSE,
- wt, span = "cv", bass = 0)
+ wt, span = "cv", bass = 0, difference = FALSE)
{
stopifnot(identical(make.plot, TRUE) || identical(make.plot, FALSE),
identical(pos.slope, FALSE) || identical(pos.slope, TRUE),
@@ -24,7 +24,7 @@
nyrs = nyrs, f = f, pos.slope = pos.slope,
constrain.nls = constrain2,
verbose = FALSE, return.info = return.info,
- span = span, bass = bass))
+ span = span, bass = bass, difference = difference))
if (!missing(wt)) {
detrend.args <- c(detrend.args, list(wt = wt))
}
Modified: pkg/dplR/R/detrend.series.R
===================================================================
--- pkg/dplR/R/detrend.series.R 2018-06-19 01:23:42 UTC (rev 1118)
+++ pkg/dplR/R/detrend.series.R 2018-06-20 20:12:39 UTC (rev 1119)
@@ -4,7 +4,7 @@
nyrs = NULL, f = 0.5, pos.slope = FALSE,
constrain.nls = c("never", "when.fail", "always"),
verbose = FALSE, return.info = FALSE,
- wt, span = "cv", bass = 0)
+ wt, span = "cv", bass = 0, difference = FALSE)
{
check.flags(make.plot, pos.slope, verbose, return.info)
if (length(y.name) == 0) {
@@ -42,7 +42,8 @@
"return.info" = return.info,
"wt" = wt.description,
"span" = span,
- "bass" = bass)
+ "bass" = bass,
+ "difference" = difference)
optNames <- names(opts)
optChar <- c(gettext("Options", domain="R-dplR"),
paste(str_pad(optNames,
@@ -232,7 +233,8 @@
} else {
mneStats <- NULL
}
- resids$ModNegExp <- y2 / ModNegExp
+ if(difference){ resids$ModNegExp <- y2 - ModNegExp }
+ else{ resids$ModNegExp <- y2 / ModNegExp }
curves$ModNegExp <- ModNegExp
modelStats$ModNegExp <- mneStats
do.mne <- TRUE
@@ -376,7 +378,8 @@
} else {
hugStats <- NULL
}
- resids$ModHugershoff <- y2 / ModHugershoff
+ if(difference){ resids$ModHugershoff <- y2 - ModHugershoff }
+ else{ resids$ModHugershoff <- y2 / ModHugershoff }
curves$ModHugershoff <- ModHugershoff
modelStats$ModHugershoff <- hugStats
do.hug <- TRUE
@@ -409,7 +412,8 @@
} else {
splineStats <- list(method = "Spline", nyrs = nyrs2, f = f)
}
- resids$Spline <- y2 / Spline
+ if(difference){ resids$Spline <- y2 - Spline }
+ else{ resids$Spline <- y2 / Spline }
curves$Spline <- Spline
modelStats$Spline <- splineStats
@@ -429,7 +433,8 @@
sep = "\n")
}
meanStats <- list(method = "Mean", mean = theMean)
- resids$Mean <- y2 / Mean
+ if(difference){ resids$Mean <- y2 - Mean }
+ else{ resids$Mean <- y2 / Mean }
curves$Mean <- Mean
modelStats$Mean <- meanStats
do.mean <- TRUE
@@ -456,7 +461,8 @@
warning("Ar fit is not all positive")
Ar[Ar<0] <- 0
}
- resids$Ar <- Ar / mean(Ar,na.rm=TRUE)
+ if(difference){ Ar - mean(Ar,na.rm=TRUE) }
+ else{ resids$Ar <- Ar / mean(Ar,na.rm=TRUE) }
curves$Ar <- mean(Ar,na.rm=TRUE)
modelStats$Ar <- arStats
do.ar <- TRUE
@@ -483,7 +489,8 @@
Friedman <- supsmu(x = seq_len(nY2), y = y2, wt = wt, span = span,
periodic = FALSE, bass = bass)[["y"]]
}
- resids$Friedman <- y2 / Friedman
+ if(difference){ resids$Friedman <- y2 - Friedman }
+ else{ resids$Friedman <- y2 / Friedman }
curves$Friedman <- Friedman
modelStats$Friedman <-
list(method = "Friedman",
@@ -557,7 +564,8 @@
main=gettext("Spline", domain="R-dplR"),
xlab=gettext("Age (Yrs)", domain="R-dplR"),
ylab=gettext("RWI", domain="R-dplR"))
- abline(h=1)
+ if(difference){ abline(h=0) }
+ else{ abline(h=1) }
}
if(do.mne){
@@ -566,7 +574,9 @@
domain="R-dplR"),
xlab=gettext("Age (Yrs)", domain="R-dplR"),
ylab=gettext("RWI", domain="R-dplR"))
- abline(h=1)
+ if(difference){ abline(h=0) }
+ else{ abline(h=1) }
+
}
if(do.mean){
@@ -574,14 +584,17 @@
main=gettext("Horizontal Line (Mean)", domain="R-dplR"),
xlab=gettext("Age (Yrs)", domain="R-dplR"),
ylab=gettext("RWI", domain="R-dplR"))
- abline(h=1)
+ if(difference){ abline(h=0) }
+ else{ abline(h=1) }
+
}
if(do.ar){
plot(resids$Ar, type="l", col=cols[4],
main=gettextf("Ar", domain="R-dplR"),
xlab=gettext("Age (Yrs)", domain="R-dplR"),
ylab=gettext("RWI", domain="R-dplR"))
- abline(h=1)
+ if(difference){ abline(h=0) }
+ else{ abline(h=1) }
mtext(text="(Not plotted with raw series)",side=3,line=-1,cex=0.75)
}
@@ -590,7 +603,9 @@
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)
+ if(difference){ abline(h=0) }
+ else{ abline(h=1) }
+
}
if(do.hug){
plot(resids$ModHugershoff, type="l", col=cols[6],
@@ -598,7 +613,9 @@
domain="R-dplR"),
xlab=gettext("Age (Yrs)", domain="R-dplR"),
ylab=gettext("RWI", domain="R-dplR"))
- abline(h=1)
+ if(difference){ abline(h=0) }
+ else{ abline(h=1) }
+
}
}
Modified: pkg/dplR/R/pass.filt.R
===================================================================
--- pkg/dplR/R/pass.filt.R 2018-06-19 01:23:42 UTC (rev 1118)
+++ pkg/dplR/R/pass.filt.R 2018-06-20 20:12:39 UTC (rev 1119)
@@ -21,7 +21,7 @@
f <- W
}
- # sort f in case it's passed in bcakwards
+ # sort f in case it's passed in backwards
f <- sort(f)
method <- method[1]
Modified: pkg/dplR/R/spag.plot.R
===================================================================
--- pkg/dplR/R/spag.plot.R 2018-06-19 01:23:42 UTC (rev 1118)
+++ pkg/dplR/R/spag.plot.R 2018-06-20 20:12:39 UTC (rev 1119)
@@ -5,7 +5,8 @@
stop("empty 'rwl' given, nothing to draw")
}
rwl2 <- scale(rwl * zfac, center = TRUE, scale = FALSE) # result is a matrix
- yr <- as.numeric(rownames(rwl2))
+ rwl2 <- as.rwl(rwl2)
+ yr <- time(rwl2)
first.year <- as.matrix(apply(rwl2, 2, yr.range, yr.vec=yr))[1, ]
neworder <- order(first.year, decreasing=FALSE)
rwl2 <- rwl2[, neworder, drop=FALSE]
Added: pkg/dplR/man/as.rwl.Rd
===================================================================
--- pkg/dplR/man/as.rwl.Rd (rev 0)
+++ pkg/dplR/man/as.rwl.Rd 2018-06-20 20:12:39 UTC (rev 1119)
@@ -0,0 +1,44 @@
+\encoding{UTF-8}
+\name{as.rwl}
+\alias{as.rwl}
+\title{ as.rwl }
+\description{
+ Attempts to turn its argument into a rwl object.
+}
+\usage{
+as.rwl(x)
+}
+\arguments{
+ \item{x}{ a \code{data.frame} or \code{matrix} with series as columns and years as rows }
+}
+\details{
+ This tries to coerce \code{x} into class \code{c("rwl","data,frame")}. Failable.
+}
+\value{
+ An object of class \code{c("rwl", "data.frame")} with the series in
+ columns and the years as rows. The series \acronym{ID}s are the
+ column names and the years are the row names.
+}
+
+\author{ Andy Bunn. Patched and improved by Mikko Korpela. }
+\examples{
+library(graphics)
+library(stats)
+library(utils)
+## Toy
+n <- 100
+## Make a data.frame that is tree-ring like
+base.series <- 0.75 + exp(-0.2 * 1:n)
+foo <- data.frame(x1 = base.series + abs(rnorm(n, 0, 0.25)),
+ x2 = base.series + abs(rnorm(n, 0, 0.25)),
+ x3 = base.series + abs(rnorm(n, 0, 0.25)),
+ x4 = base.series + abs(rnorm(n, 0, 0.25)),
+ x5 = base.series + abs(rnorm(n, 0, 0.25)),
+ x6 = base.series + abs(rnorm(n, 0, 0.25)))
+# coerce to rwl and use plot and summary methods
+foo <- as.rwl(foo)
+class(foo)
+plot(foo,plot.type="spag")
+summary(foo)
+}
+\keyword{ manip }
Property changes on: pkg/dplR/man/as.rwl.Rd
___________________________________________________________________
Added: svn:eol-style
+ native
Modified: pkg/dplR/man/crn.plot.Rd
===================================================================
--- pkg/dplR/man/crn.plot.Rd 2018-06-19 01:23:42 UTC (rev 1118)
+++ pkg/dplR/man/crn.plot.Rd 2018-06-20 20:12:39 UTC (rev 1119)
@@ -72,10 +72,11 @@
cana157.mod <- cana157
cana157.mod$samp.depth <- NULL
crn.plot(cana157.mod, add.spline = TRUE)
-## A raw ring-width chronology
+## A raw ring-width chronology with prewhitening
data(ca533)
ca533.raw.crn <- chron(ca533, prefix = "CAM", prewhiten=TRUE)
-plot(ca533.raw.crn,abline.pos=NULL,ylab='mm')
+plot(ca533.raw.crn,ylab='mm',
+ abline.pos=mean(ca533.raw.crn[,1],na.rm = TRUE))
\dontrun{
# not pretty - but illustrates the coloring options
Modified: pkg/dplR/man/detrend.Rd
===================================================================
--- pkg/dplR/man/detrend.Rd 2018-06-19 01:23:42 UTC (rev 1118)
+++ pkg/dplR/man/detrend.Rd 2018-06-20 20:12:39 UTC (rev 1119)
@@ -12,7 +12,7 @@
nyrs = NULL, f = 0.5, pos.slope = FALSE,
constrain.nls = c("never", "when.fail", "always"),
verbose = FALSE, return.info = FALSE,
- wt, span = "cv", bass = 0)
+ wt, span = "cv", bass = 0, difference = FALSE)
}
\arguments{
@@ -63,6 +63,9 @@
\item{bass}{ a \code{numeric} value controlling the smoothness of the
fitted curve in method \code{"Friedman"}. See \code{\link{supsmu}}. }
+
+ \item{difference}{ a \code{logical} flag. Compute residuals by substraction if TRUE, otherwise use division. }
+
}
\details{
See \code{\link{detrend.series}} for details on detrending
@@ -108,7 +111,10 @@
data(ca533)
## Detrend using modified exponential decay. Returns a data.frame
ca533.rwi <- detrend(rwl = ca533, method = "ModNegExp")
-## Detrend using modified Hugershoff curve and return info on the model fits.
+## Detrend using a slines on power transformed data and compute residuals via subtraction
+ca533.rwi <- detrend(rwl = powt(ca533), method = "Spline", difference = TRUE)
+
+## Detrend using modified Hugershoff curve and return info on the model fits.
## Returns a list with: series, curves, modelinfo and data.info
data(co021)
co021.rwi <- detrend(rwl = co021, method = "ModHugershoff", return.info=TRUE)
Modified: pkg/dplR/man/detrend.series.Rd
===================================================================
--- pkg/dplR/man/detrend.series.Rd 2018-06-19 01:23:42 UTC (rev 1118)
+++ pkg/dplR/man/detrend.series.Rd 2018-06-20 20:12:39 UTC (rev 1119)
@@ -13,7 +13,7 @@
nyrs = NULL, f = 0.5, pos.slope = FALSE,
constrain.nls = c("never", "when.fail", "always"),
verbose = FALSE, return.info = FALSE,
- wt, span = "cv", bass = 0)
+ wt, span = "cv", bass = 0, difference = FALSE)
}
\arguments{
@@ -70,6 +70,9 @@
\item{bass}{ a \code{numeric} value controlling the smoothness of the
fitted curve in method \code{"Friedman"}. See \code{\link{supsmu}}. }
+
+ \item{difference}{ a \code{logical} flag. Compute residuals by substraction if TRUE, otherwise use division. }
+
}
\details{
This detrends and standardizes a tree-ring series. The detrending is
@@ -244,7 +247,8 @@
series.rwi <- detrend.series(y = series, y.name = "CAM011", verbose=TRUE)
# see plot with three methods
series.rwi <- detrend.series(y = series, y.name = "CAM011",
- method=c("Spline", "ModNegExp","Friedman"))
+ method=c("Spline", "ModNegExp","Friedman"),
+ difference=TRUE)
# see plot with two methods
# interesting to note difference from ~200 to 250 years
# in terms of what happens to low frequency growth
Modified: pkg/dplR/man/pass.filt.Rd
===================================================================
--- pkg/dplR/man/pass.filt.Rd 2018-06-19 01:23:42 UTC (rev 1118)
+++ pkg/dplR/man/pass.filt.Rd 2018-06-20 20:12:39 UTC (rev 1119)
@@ -15,6 +15,7 @@
\item{W}{ a \code{numeric} vector giving frequency or period of the filter. See details. }
\item{type}{ a \code{character} giving the type of filter. Values can be "low", "high", "stop", or "pass" for low-pass, high-pass, band-pass, or stop-pass filters. Defaults to "low". }
\item{method}{ a \code{character} specifying indicating whether to use a Butterworth or a type I Chebyshev filter.}
+ \item{n}{ a \code{numeric} value giving the order of the filter. Larger numbers create steeper fall off.}
\item{Rp}{ a \code{numeric} value giving the dB for the passband ripple. }
}
Modified: pkg/dplR/man/spag.plot.Rd
===================================================================
--- pkg/dplR/man/spag.plot.Rd 2018-06-19 01:23:42 UTC (rev 1118)
+++ pkg/dplR/man/spag.plot.Rd 2018-06-20 20:12:39 UTC (rev 1119)
@@ -38,7 +38,7 @@
\seealso{ \code{\link{seg.plot}} }
\examples{library(utils)
data(co021)
-spag.plot(co021)
+plot(co021,plot.type = "spag")
spag.plot(co021, zfac = 2)
}
\keyword{ hplot }
More information about the Dplr-commits
mailing list