From noreply at r-forge.r-project.org Wed Jun 13 10:24:29 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 13 Jun 2018 10:24:29 +0200 (CEST) Subject: [Dplr-commits] r1110 - in pkg/dplR: . R man Message-ID: <20180613082429.84E4C18E246@r-forge.r-project.org> 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 From noreply at r-forge.r-project.org Wed Jun 13 12:56:54 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 13 Jun 2018 12:56:54 +0200 (CEST) Subject: [Dplr-commits] r1111 - pkg/dplR/R Message-ID: <20180613105654.76A8F18D208@r-forge.r-project.org> Author: andybunn Date: 2018-06-13 12:56:54 +0200 (Wed, 13 Jun 2018) New Revision: 1111 Modified: pkg/dplR/R/detrend.R Log: Small error fixed. Modified: pkg/dplR/R/detrend.R =================================================================== --- pkg/dplR/R/detrend.R 2018-06-13 08:24:28 UTC (rev 1110) +++ pkg/dplR/R/detrend.R 2018-06-13 10:56:54 UTC (rev 1111) @@ -87,8 +87,10 @@ 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){ + modelCurves <- data.frame(modelCurves, row.names = rn) + names(modelCurves) <- y.name + } } if (return.info) { names(modelStats) <- series.names From noreply at r-forge.r-project.org Thu Jun 14 12:50:48 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 14 Jun 2018 12:50:48 +0200 (CEST) Subject: [Dplr-commits] r1112 - in pkg/dplR: R man Message-ID: <20180614105049.0767518C6CB@r-forge.r-project.org> Author: andybunn Date: 2018-06-14 12:50:48 +0200 (Thu, 14 Jun 2018) New Revision: 1112 Modified: pkg/dplR/R/detrend.R pkg/dplR/R/detrend.series.R pkg/dplR/man/detrend.Rd pkg/dplR/man/detrend.series.Rd Log: Added hughershoff curve to detrend. Needs some work on th constrain args likely. Modified: pkg/dplR/R/detrend.R =================================================================== --- pkg/dplR/R/detrend.R 2018-06-13 10:56:54 UTC (rev 1111) +++ pkg/dplR/R/detrend.R 2018-06-14 10:50:48 UTC (rev 1112) @@ -1,8 +1,8 @@ `detrend` <- function(rwl, y.name = names(rwl), make.plot = FALSE, - method=c("Spline", "ModNegExp", "Mean", "Ar", "Friedman"), + method=c("Spline", "ModNegExp", "Mean", "Ar", "Friedman", "ModHugershoff"), nyrs = NULL, f = 0.5, pos.slope = FALSE, - constrain.modnegexp = c("never", "when.fail", "always"), + constrain.nls = c("never", "when.fail", "always"), verbose = FALSE, return.info = FALSE, wt, span = "cv", bass = 0) { @@ -10,8 +10,8 @@ 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", "Friedman") - constrain2 <- match.arg(constrain.modnegexp) + known.methods <- c("Spline", "ModNegExp", "Mean", "Ar", "Friedman", "ModHugershoff") + constrain2 <- match.arg(constrain.nls) method2 <- match.arg(arg = method, choices = known.methods, several.ok = TRUE) @@ -22,14 +22,14 @@ detrend.args <- c(alist(rwl.i), list(make.plot = make.plot, method = method2, nyrs = nyrs, f = f, pos.slope = pos.slope, - constrain.modnegexp = constrain2, + constrain.nls = 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) && + ("Spline" %in% method2 || "ModNegExp" %in% method2 || "ModHugershoff" %in% method2) && !inherits(try(suppressWarnings(req.it <- requireNamespace("iterators", quietly=TRUE)), @@ -62,6 +62,7 @@ n.series <- ncol(rwl) out <- vector(mode = "list", length = n.series) if (return.info) { + modelCurves <- vector(mode = "list", length = n.series) modelStats <- vector(mode = "list", length = n.series) dataStats <- vector(mode = "list", length = n.series) } Modified: pkg/dplR/R/detrend.series.R =================================================================== --- pkg/dplR/R/detrend.series.R 2018-06-13 10:56:54 UTC (rev 1111) +++ pkg/dplR/R/detrend.series.R 2018-06-14 10:50:48 UTC (rev 1112) @@ -1,8 +1,8 @@ `detrend.series` <- function(y, y.name = "", make.plot = TRUE, - method = c("Spline", "ModNegExp", "Mean", "Ar", "Friedman"), + method = c("Spline", "ModNegExp", "Mean", "Ar", "Friedman","ModHugershoff"), nyrs = NULL, f = 0.5, pos.slope = FALSE, - constrain.modnegexp = c("never", "when.fail", "always"), + constrain.nls = c("never", "when.fail", "always"), verbose = FALSE, return.info = FALSE, wt, span = "cv", bass = 0) { @@ -13,8 +13,8 @@ y.name2 <- as.character(y.name)[1] stopifnot(Encoding(y.name2) != "bytes") } - known.methods <- c("Spline", "ModNegExp", "Mean", "Ar", "Friedman") - constrain2 <- match.arg(constrain.modnegexp) + known.methods <- c("Spline", "ModNegExp", "Mean", "Ar", "Friedman","ModHugershoff") + constrain2 <- match.arg(constrain.nls) method2 <- match.arg(arg = method, choices = known.methods, several.ok = TRUE) @@ -37,7 +37,7 @@ "nyrs" = if (is.null(nyrs)) "NULL" else nyrs, "f" = f, "pos.slope" = pos.slope, - "constrain.modnegexp" = constrain2, + "constrain.nls" = constrain2, "verbose" = verbose, "return.info" = return.info, "wt" = wt.description, @@ -173,7 +173,7 @@ } ## Straight line via linear regression if (mneNotPositive) { - warning("Fits from ModNegExp are not all positive, see constrain.modnegexp argument in detrend.series") + warning("Fits from ModNegExp are not all positive, see constrain.nls argument in detrend.series") } x <- seq_len(nY2) lm1 <- lm(y2 ~ x) @@ -239,7 +239,151 @@ } else { do.mne <- FALSE } - + if("ModHugershoff" %in% method2){ + ## hug or lm + hug.func <- function(Y, constrain) { + nY <- length(Y) + a <- mean(Y[floor(nY * 0.9):nY]) + b <- 1 + g <- 0.1 + d <- mean(Y[floor(nY * 0.9):nY]) + nlsForm <- Y ~ I(a*seq_along(Y)^b*exp(-g*seq_along(Y))+d) + nlsStart <- list(a=a, b=b, g=g, d=d) + checked <- FALSE + constrained <- FALSE + ## Note: nls() may signal an error + if (constrain == "never") { + hug <- nls(formula = nlsForm, start = nlsStart) + } else if (constrain == "always") { + hug <- nls(formula = nlsForm, start = nlsStart, + lower = c(a=0, b=-Inf, g=0, d=0), + upper = c(a=Inf, b=0, g=Inf, d=Inf), + algorithm = "port") + constrained <- TRUE + } else { + hug <- nls(formula = nlsForm, start = nlsStart) + coefs <- coef(hug) + if (coefs[1] <= 0 || coefs[2] <= 0) { + stop() + } + fits <- predict(hug) + if (fits[nY] > 0) { + checked <- TRUE + } else { + hug <- nls(formula = nlsForm, start = nlsStart, + lower = c(a=0, b=-Inf, g=0, d=0), + upper = c(a=Inf, b=0, g=Inf, d=Inf), + algorithm = "port") + constrained <- TRUE + } + } + if (!checked) { + coefs <- coef(hug) + if (coefs[1] <= 0 || coefs[2] <= 0) { + stop() + } + fits <- predict(hug) + if (fits[nY] <= 0) { + ## This error is a special case that needs to be + ## detected (if only for giving a warning). Any + ## smarter way to implement this? + return(NULL) + } + } + tmpFormula <- nlsForm + formEnv <- new.env(parent = environment(detrend.series)) + formEnv[["Y"]] <- Y + formEnv[["a"]] <- coefs["a"] + formEnv[["b"]] <- coefs["b"] + formEnv[["g"]] <- coefs["g"] + formEnv[["d"]] <- coefs["d"] + environment(tmpFormula) <- formEnv + structure(fits, constrained = constrained, + formula = tmpFormula, summary = summary(hug)) + } + ModHugershoff <- try(hug.func(y2, constrain2), silent=TRUE) + hugNotPositive <- is.null(ModHugershoff) + + if (verbose) { + cat("", sepLine, sep = "\n") + cat(indent(gettext("Detrend by ModHugershoff.\n", domain = "R-dplR"))) + cat(indent(gettext("Trying to fit nls model...\n", + domain = "R-dplR"))) + } + if (hugNotPositive || class(ModHugershoff) == "try-error") { + if (verbose) { + cat(indent(gettext("nls failed... fitting linear model...", + domain = "R-dplR"))) + } + ## Straight line via linear regression + if (hugNotPositive) { + warning("Fits from ModHugershoff are not all positive, see constrain.nls argument in detrend.series") + } + x <- seq_len(nY2) + lm1 <- lm(y2 ~ x) + coefs <- coef(lm1) + xIdx <- names(coefs) == "x" + coefs <- c(coefs[!xIdx], coefs[xIdx]) + if (verbose) { + cat(indent(c(gettext("Linear model fit", domain = "R-dplR"), + gettextf("Intercept: %s", format(coefs[1]), + domain = "R-dplR"), + gettextf("Slope: %s", format(coefs[2]), + domain = "R-dplR"))), + sep = "\n") + } + if (all(is.finite(coefs)) && (coefs[2] <= 0 || pos.slope)) { + tm <- cbind(1, x) + ModHugershoff <- drop(tm %*% coefs) + useMean <- !isTRUE(ModHugershoff[1] > 0 && + ModHugershoff[nY2] > 0) + if (useMean) { + warning("Linear fit (backup of ModHugershoff) is not all positive") + } + } else { + useMean <- TRUE + } + if (useMean) { + theMean <- mean(y2) + if (verbose) { + cat(indent(c(gettext("lm has a positive slope", + "pos.slope = FALSE", + "Detrend by mean.", + domain = "R-dplR"), + gettextf("Mean = %s", format(theMean), + domain = "R-dplR"))), + sep = "\n") + } + ModHugershoff <- rep.int(theMean, nY2) + hugStats <- list(method = "Mean", mean = theMean) + } else { + hugStats <- list(method = "Line", coefs = coef(summary(lm1))) + } + } else if (verbose || return.info) { + hugSummary <- attr(ModHugershoff, "summary") + hugCoefs <- hugSummary[["coefficients"]] + hugCoefsE <- hugCoefs[, 1] + if (verbose) { + cat(indent(c(gettext("nls coefs", domain = "R-dplR"), + paste0(names(hugCoefsE), ": ", + format(hugCoefsE)))), + sep = "\n") + } + hugStats <- list(method = "Hugershoff", + is.constrained = attr(ModHugershoff, "constrained"), + formula = attr(ModHugershoff, "formula"), + coefs = hugCoefs) + } else { + hugStats <- NULL + } + resids$ModHugershoff <- y2 / ModHugershoff + curves$ModHugershoff <- ModHugershoff + modelStats$ModHugershoff <- hugStats + do.hug <- TRUE + } else { + do.hug <- FALSE + } + if("Spline" %in% method2){ ## Smoothing spline ## "n-year spline" as the spline whose frequency response is @@ -379,11 +523,12 @@ } if(make.plot){ + cols <- c("#8c510a","#d8b365","#f6e8c3","#c7eae5","#5ab4ac","#01665e") 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') + tcl=0.5, xaxs="i") if (n.methods > 4) { par(cex.main = min(1, par("cex.main"))) } @@ -392,21 +537,23 @@ 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,1,2,3,4,5,6,0), nrow=3, ncol=3, byrow=TRUE)) + matrix(c(1,1,1,2,3,4,5,6,0), nrow=3, ncol=3, byrow=TRUE), + matrix(c(1,1,1,2,3,4,5,6,7), nrow=3, ncol=3, byrow=TRUE)) layout(mat, widths=rep.int(0.5, ncol(mat)), heights=rep.int(1, nrow(mat))) - plot(y2, type="l", ylab="mm", + plot(y2, type="l", ylab="mm", col = "grey", xlab=gettext("Age (Yrs)", 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) - if(do.friedman) lines(Friedman, col="cyan", lwd=2) - + if(do.spline) lines(Spline, col=cols[1], lwd=2) + if(do.mne) lines(ModNegExp, col=cols[2], lwd=2) + if(do.mean) lines(Mean, col=cols[3], lwd=2) + if(do.friedman) lines(Friedman, col=cols[5], lwd=2) + if(do.hug) lines(ModHugershoff, col=cols[6], lwd=2) + if(do.spline){ - plot(resids$Spline, type="l", col="green", + plot(resids$Spline, type="l", col=cols[1], main=gettext("Spline", domain="R-dplR"), xlab=gettext("Age (Yrs)", domain="R-dplR"), ylab=gettext("RWI", domain="R-dplR")) @@ -414,7 +561,7 @@ } if(do.mne){ - plot(resids$ModNegExp, type="l", col="red", + plot(resids$ModNegExp, type="l", col=cols[2], main=gettext("Neg. Exp. Curve or Straight Line", domain="R-dplR"), xlab=gettext("Age (Yrs)", domain="R-dplR"), @@ -423,14 +570,14 @@ } if(do.mean){ - plot(resids$Mean, type="l", col="blue", + plot(resids$Mean, type="l", col=cols[3], 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(do.ar){ - plot(resids$Ar, type="l", col="purple", + 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")) @@ -439,12 +586,21 @@ } if (do.friedman) { - plot(resids$Friedman, type="l", col="cyan", + plot(resids$Friedman, type="l", col=cols[5], 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(do.hug){ + plot(resids$ModHugershoff, type="l", col=cols[6], + main=gettext("Hugershoff or Straight Line", + 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/man/detrend.Rd =================================================================== --- pkg/dplR/man/detrend.Rd 2018-06-13 10:56:54 UTC (rev 1111) +++ pkg/dplR/man/detrend.Rd 2018-06-14 10:50:48 UTC (rev 1112) @@ -8,9 +8,9 @@ } \usage{ detrend(rwl, y.name = names(rwl), make.plot = FALSE, - method = c("Spline", "ModNegExp", "Mean", "Ar", "Friedman"), + method = c("Spline", "ModNegExp", "Mean", "Ar", "Friedman", "ModHugershoff"), nyrs = NULL, f = 0.5, pos.slope = FALSE, - constrain.modnegexp = c("never", "when.fail", "always"), + constrain.nls = c("never", "when.fail", "always"), verbose = FALSE, return.info = FALSE, wt, span = "cv", bass = 0) } @@ -28,8 +28,8 @@ \item{method}{ a \code{character} vector to determine the detrending methods. See details below. Possible values are all subsets of - \code{c("Spline", "ModNegExp", "Mean", "Ar", "Friedman")}. Defaults to - using all the available methods.} + \code{c("Spline", "ModNegExp", "Mean", "Ar", "Friedman", "ModHugershoff")}. + Defaults to using all the available methods.} \item{nyrs}{ a number giving the rigidity of the smoothing spline, defaults to 0.67 of series length if \code{\var{nyrs}} is @@ -39,11 +39,13 @@ wavelength cutoff. Defaults to 0.5. } \item{pos.slope}{ a \code{logical} flag. Will allow for a positive - slope to be used in method \code{"ModNegExp"}. If \code{FALSE} the + slope to be used in method \code{"ModNegExp"} and \code{"ModHugershoff"}. + If \code{FALSE} the line will be horizontal. } - \item{constrain.modnegexp}{ a \code{character} string which controls - the constraints of the \code{"ModNegExp"} model. See + \item{constrain.nls}{ a \code{character} string which controls + the constraints of the \code{"ModNegExp"} model and the + \code{"ModHugershoff"}. See \code{\link{detrend.series}} for further details. } \item{verbose}{ \code{logical}. Write out details? } @@ -106,6 +108,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. +## Returns a list with: series, curves, modelinfo and data.info +data(co021) +co021.rwi <- detrend(rwl = co021, method = "ModHugershoff", return.info=TRUE) \dontrun{ library(grDevices) Modified: pkg/dplR/man/detrend.series.Rd =================================================================== --- pkg/dplR/man/detrend.series.Rd 2018-06-13 10:56:54 UTC (rev 1111) +++ pkg/dplR/man/detrend.series.Rd 2018-06-14 10:50:48 UTC (rev 1112) @@ -8,9 +8,9 @@ } \usage{ detrend.series(y, y.name = "", make.plot = TRUE, - method = c("Spline", "ModNegExp", "Mean", "Ar", "Friedman"), + method = c("Spline", "ModNegExp", "Mean", "Ar", "Friedman", "ModHugershoff"), nyrs = NULL, f = 0.5, pos.slope = FALSE, - constrain.modnegexp = c("never", "when.fail", "always"), + constrain.nls = c("never", "when.fail", "always"), verbose = FALSE, return.info = FALSE, wt, span = "cv", bass = 0) } @@ -42,17 +42,19 @@ slope to be used in method \code{"ModNegExp"}. If \code{FALSE} the line will be horizontal. } - \item{constrain.modnegexp}{ a \code{character} string which controls - the constraints of the \code{"ModNegExp"} model. The value is an - answer to the question: When should the parameters of the modified - negative exponential function be constrained? The options are + \item{constrain.nls}{ a \code{character} string which controls + the constraints of the \code{"ModNegExp"} model and and the + \code{"ModHugershoff"} model which are fit using nonlinear least-squares + via \code{\link{nls}}. The value is an + answer to the question: When should the parameters of the \code{\link{nls}} + function be constrained? The options are \code{"never"}: do not constrain (the default), \code{"when.fail"}: only compute the constrained solution if the unconstrained fit contains other than positive values, and \code{"always"}: return the constrained solution, even if the unconstrained one would have been valid. See \sQuote{Details}. } - \item{verbose}{ a \code{logical} flag. Write out details? } + \item{verbose}{ a \code{logical} flag. Write out details to the screen? } \item{return.info}{ a \code{logical} flag. If \code{TRUE}, details about models and data will be added to the return value. See @@ -73,31 +75,32 @@ the estimation and removal of the tree\enc{?}{'}s natural biological growth trend. The standardization is done by dividing each series by the growth trend to produce units in the dimensionless ring-width index - (\acronym{RWI}). There are currently three methods available for + (\acronym{RWI}). There are currently six methods available for detrending although more are certainly possible. The methods implemented are a smoothing spline via \code{\link{ffcsaps}} (\code{\var{method} = "Spline"}), a modified negative exponential - curve (\code{\var{method} = "ModNegExp"}), or a simple horizontal line - (\code{\var{method} = "Mean"}). + curve (\code{\var{method} = "ModNegExp"}), a simple horizontal line + (\code{\var{method} = "Mean"}), the residuals of an AR model + (\code{\var{method} = "Ar"}), Friedman's Super Smoother + (\code{\var{method} = "Friedman"}), or a modified Hugershoff + curve (\code{\var{method} = "ModHugershoff"}). The \code{"Spline"} approach uses an spline where the frequency response is 0.50 at a wavelength of 0.67 * \dQuote{series length in years}, unless specified differently using \code{\var{nyrs}} and - \code{\var{f}} in the function \code{\link{ffcsaps}}. This attempts - to remove the low frequency variability that is due to biological or - stand effects. + \code{\var{f}} in the function \code{\link{ffcsaps}}. The \code{"ModNegExp"} approach attempts to fit a classic nonlinear model of biological growth of the form \eqn{f(t) = a e^{b t} + k}{f(t) = a exp(b t) + k}, where the argument of the function is time, using \code{\link{nls}}. See Fritts (2001) for details about the - parameters. Option \code{\var{constrain.modnegexp}} gives a + parameters. Option \code{\var{constrain.nls}} gives a possibility to constrain the parameters of the modified negative exponential function. If the constraints are enabled, the nonlinear optimization algorithm is instructed to keep the parameters in the following ranges: \eqn{a \ge 0}{a >= 0}, \eqn{b \le 0}{b <= 0} and \eqn{k \ge 0}{k >= 0}. The default is to not constrain the parameters - (\code{\var{constrain.modnegexp} = "never"}) for \code{\link{nls}} but + (\code{\var{constrain.nls} = "never"}) for \code{\link{nls}} but warn the user when the parameters go out of range. If a suitable nonlinear model cannot be fit @@ -118,6 +121,25 @@ This method removes all but the high frequency variation in the series and should only be used as such. + The \code{"ModHugershoff"} approach attempts to fit a Hugershoff + model of biological growth of the form \eqn{f(t) = a t^b e^{-g t} + d}{f(t) + = a t^b exp(-g t) + d}, where the argument of the function is time, using + \code{\link{nls}}. See Fritts (2001) for details about the + parameters. Option \code{\var{constrain.nls}} gives a + possibility to constrain the parameters of the modified negative + exponential function. If the constraints are enabled, the nonlinear + optimization algorithm is instructed to keep the parameters in the + following ranges: \eqn{a \ge 0}{a >= 0}, \eqn{b \ge 0}{b >= 0} and + \eqn{d \ge 0}{d >= 0}. The default is to not constrain the parameters + (\code{\var{constrain.nls} = "never"}) for \code{\link{nls}} but + warn the user when the parameters go out of range. + + If a suitable nonlinear model cannot be fit + (function is non-decreasing or some values are not positive) then a + linear model is fit. That linear model can have a positive slope + unless \code{\var{pos.slope}} is \code{FALSE} in which case method + \code{"Mean"} is used. + These methods are chosen because they are commonly used in dendrochronology. There is a rich literature on detrending and many researchers are particularly skeptical of the use of the @@ -177,7 +199,7 @@ \item{is.constrained}{ A \code{logical} flag indicating whether the parameters of the \code{"ModNegExp"} model were constrained. Only interesting when argument - \code{\var{constrain.modnegexp}} is set to \code{"when.fail"}. } + \code{\var{constrain.nls}} is set to \code{"when.fail"}. } \item{nyrs}{ The value of \code{\var{nyrs}} used for \code{\link{ffcsaps}}. Only for method \code{"Spline"}. } @@ -213,16 +235,11 @@ \seealso{ \code{\link{detrend}} } \examples{library(stats) library(utils) -## Using a plausible representation of a tree-ring series -gt <- 0.5 * exp (-0.05 * 1:200) + 0.2 -noise <- c(arima.sim(model = list(ar = 0.7), n = 200, sd = 0.5))+2 -series <- gt * noise -series.rwi <- detrend.series(y = series, y.name = "Foo", verbose=TRUE) ## Use series CAM011 from the Campito data set data(ca533) series <- ca533[, "CAM011"] names(series) <- rownames(ca533) -# defaults to all five methods +# defaults to all six methods 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", @@ -240,5 +257,14 @@ # since this approach doesn't approximate a growth curve. series.rwi <- detrend.series(y = series, y.name = "CAM011", method="Ar") +# note the difference between ModNegExp and ModHugershoff at the +# start of the series +data(co021) +series <- co021[, 4] +names(series) <- rownames(co021) +series.rwi <- detrend.series(y = series, y.name = names(co021)[4], + method=c("ModNegExp", "ModHugershoff"), + verbose = T, return.info = T, make.plot = T) + } \keyword{ manip } From noreply at r-forge.r-project.org Thu Jun 14 13:16:01 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 14 Jun 2018 13:16:01 +0200 (CEST) Subject: [Dplr-commits] r1113 - pkg/dplR/R Message-ID: <20180614111601.1953C1841FE@r-forge.r-project.org> Author: andybunn Date: 2018-06-14 13:16:00 +0200 (Thu, 14 Jun 2018) New Revision: 1113 Modified: pkg/dplR/R/detrend.R Log: Suppressed warning ?\226?\128?\156executing %dopar% sequentially: no parallel backend registered ?\226?\128?\156 Modified: pkg/dplR/R/detrend.R =================================================================== --- pkg/dplR/R/detrend.R 2018-06-14 10:50:48 UTC (rev 1112) +++ pkg/dplR/R/detrend.R 2018-06-14 11:16:00 UTC (rev 1113) @@ -45,12 +45,12 @@ rwl.i <- NULL exportFun <- c("names<-", "detrend.series") - out <- foreach::"%dopar%"(foreach::foreach(rwl.i=it.rwl, + out <- suppressWarnings(foreach::"%dopar%"(foreach::foreach(rwl.i=it.rwl, .export=exportFun), { names(rwl.i) <- rn do.call(detrend.series, detrend.args) - }) + })) if (return.info) { modelCurves <- lapply(out, "[[", 2) From noreply at r-forge.r-project.org Thu Jun 14 13:32:01 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 14 Jun 2018 13:32:01 +0200 (CEST) Subject: [Dplr-commits] r1114 - in pkg/dplR: . R man Message-ID: <20180614113201.6410618AFC6@r-forge.r-project.org> Author: andybunn Date: 2018-06-14 13:32:01 +0200 (Thu, 14 Jun 2018) New Revision: 1114 Modified: pkg/dplR/ChangeLog pkg/dplR/R/rwl.stats.R pkg/dplR/man/rwl.stats.Rd Log: Removing sens1 and sens2 from rwl.stats. Modified: pkg/dplR/ChangeLog =================================================================== --- pkg/dplR/ChangeLog 2018-06-14 11:16:00 UTC (rev 1113) +++ pkg/dplR/ChangeLog 2018-06-14 11:32:01 UTC (rev 1114) @@ -1,10 +1,18 @@ * CHANGES IN dplR VERSION 1.6.9 +File: rwl.stats.R and .Rd +---------------- + +- Removing sens1 and sens2 from this function. At world dendro I'm still seeing these being used by dplR users. It's a terrible stat. I'm taking it out. Help file ammended. + 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. +- 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. + + File: detrend.R ---------------- Modified: pkg/dplR/R/rwl.stats.R =================================================================== --- pkg/dplR/R/rwl.stats.R 2018-06-14 11:16:00 UTC (rev 1113) +++ pkg/dplR/R/rwl.stats.R 2018-06-14 11:32:01 UTC (rev 1114) @@ -23,8 +23,8 @@ series.stats$median <- colMedians(rwl2, na.rm=TRUE) series.stats$stdev <- colSds(rwl2, na.rm=TRUE) series.stats$skew <- apply(rwl2, 2, skew) - series.stats$sens1 <- apply(rwl2, 2, sens1) - series.stats$sens2 <- apply(rwl2, 2, sens2) + #series.stats$sens1 <- apply(rwl2, 2, sens1) + #series.stats$sens2 <- apply(rwl2, 2, sens2) series.stats$gini <- apply(rwl2, 2, gini.coef) series.stats$ar1 <- apply(rwl2, 2, acf1) seq.temp <- -seq_len(4) Modified: pkg/dplR/man/rwl.stats.Rd =================================================================== --- pkg/dplR/man/rwl.stats.Rd 2018-06-14 11:16:00 UTC (rev 1113) +++ pkg/dplR/man/rwl.stats.Rd 2018-06-14 11:32:01 UTC (rev 1114) @@ -42,12 +42,10 @@ well as the length of the series (\code{"first"}, \code{"last"}, \code{"year"}). The mean, median, standard deviation are given (\code{"mean"}, \code{"median"}, \code{"stdev"}) as are the skewness, - two measures of sensitivity, the Gini coefficient, and first order - autocorrelation (\code{"skew"}, \code{"\link{sens1}"}, - \code{"\link{sens2}"}, \code{"\link{gini.coef}"}, \code{"ar1"}). + the Gini coefficient, and first order + autocorrelation (\code{"skew"}, \code{"\link{gini.coef}"}, \code{"ar1"}). - Note that mean sensitivity is not a robust statistic that should rarely, - if ever, be used (Bunn et al. 2013). + Note that prior to version 1.6.8, two measures of sensitivity were also included. However mean sensitivity is not a robust statistic that should rarely, if ever, be used (Bunn et al. 2013). Those sensitivity functions (\code{"\link{sens1}"} and \code{"\link{sens2}"}) are still available for continuity. Users should consider the coef of variation in lieu of mean sensitivity. } \references{ From noreply at r-forge.r-project.org Mon Jun 18 07:20:38 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 18 Jun 2018 07:20:38 +0200 (CEST) Subject: [Dplr-commits] r1115 - in pkg/dplR: . R man Message-ID: <20180618052038.608121808D1@r-forge.r-project.org> Author: andybunn Date: 2018-06-18 07:20:36 +0200 (Mon, 18 Jun 2018) New Revision: 1115 Added: pkg/dplR/R/pass.filt.R pkg/dplR/man/pass.filt.Rd Modified: pkg/dplR/ChangeLog pkg/dplR/NAMESPACE Log: adding a wrapper for the butterworth filter. Modified: pkg/dplR/ChangeLog =================================================================== --- pkg/dplR/ChangeLog 2018-06-14 11:32:01 UTC (rev 1114) +++ pkg/dplR/ChangeLog 2018-06-18 05:20:36 UTC (rev 1115) @@ -1,5 +1,11 @@ * CHANGES IN dplR VERSION 1.6.9 +File: pass.filt.R and .Rd +---------------- + +- Adding a wrapper function for signal:butter and signal:filtfilt to get low-pass, high-pass, band-pass filtering implemented as per a user request. + + File: rwl.stats.R and .Rd ---------------- Modified: pkg/dplR/NAMESPACE =================================================================== --- pkg/dplR/NAMESPACE 2018-06-14 11:32:01 UTC (rev 1114) +++ pkg/dplR/NAMESPACE 2018-06-18 05:20:36 UTC (rev 1115) @@ -38,6 +38,9 @@ importFrom(animation, saveGIF, ani.options) +importFrom(signal, butter, filtfilt) + + export(autoread.ids, bai.in, bai.out, ccf.series.rwl, chron, cms, combine.rwl, common.interval, corr.rwl.seg, corr.series.seg, crn.plot, detrend, detrend.series, ffcsaps, fill.internal.NA, @@ -52,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) + plotRings,time.rwl,time.crn,csv2rwl,pass.filt) S3method(print, redfit) S3method(plot, rwl) Added: pkg/dplR/R/pass.filt.R =================================================================== --- pkg/dplR/R/pass.filt.R (rev 0) +++ pkg/dplR/R/pass.filt.R 2018-06-18 05:20:36 UTC (rev 1115) @@ -0,0 +1,37 @@ +pass.filt <- function(y,W,type=c("low", "high", "stop", "pass"),n=4){ + if(any(is.na(y))) stop("y contains NA") + + # check W's length + if(type == "low" & length(W) != 1) stop("length(W) > 1") + if(type == "high" & length(W) != 1) stop("length(W) > 1") + if(type == "stop" & length(W) != 2) stop("length(W) != 2") + if(type == "pass" & length(W) !=2) stop("length(W) != 2") + + + # if W is in period (>1) then convert to f + if(any(W>1)) { + f <- 1/W + p <- W + } + + else { + p <- 1/W + f <- W + } + + # sort f in case it's passed in bcakwards + f <- sort(f) + + # initialize the butterworth filter + bFilt <- signal::butter(n=n, W=f*2, type=type, plane="z") + # pad the data to twice the max period + pad <- max(p) * 2 + ny <- length(y) + # pad the data + yPad <- c(y[pad:1],y,y[ny:(ny-pad)]) + # run the filter + yFilt <- signal::filtfilt(bFilt, yPad) + # unpad the filtered data and return + yFilt <- yFilt[(pad+1):(ny+pad)] + yFilt +} Property changes on: pkg/dplR/R/pass.filt.R ___________________________________________________________________ Added: svn:eol-style + native Added: pkg/dplR/man/pass.filt.Rd =================================================================== --- pkg/dplR/man/pass.filt.Rd (rev 0) +++ pkg/dplR/man/pass.filt.Rd 2018-06-18 05:20:36 UTC (rev 1115) @@ -0,0 +1,62 @@ +\encoding{UTF-8} +\name{pass.filt} +\alias{pass.filt} +\title{ Low-pass, high-pass, band-pass, and stop-pass filtering } +\description{ + Applies low-pass, high-pass, band-pass, or stop-pass filtering to \code{\var{y}} with frequencies (or periods) supplied by the user. +} +\usage{ +pass.filt(y, W, type=c("low", "high", "stop", "pass"), n=4) +} +\arguments{ + \item{y}{ a \code{numeric} vector, typically a tree-ring series. } + \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{n}{ a \code{numeric} value giving the order of the Butterworth filter. } +} + +\details{ + This function applies a Butterworth filter of order \code{\var{n}} to a signal and is nothing more than a wrapper for two functions in the \code{signal} package: \code{\link{butter}} and \code{\link{filtfilt}}. In this function, a Butterworth filter is initialized with the arguments given. The input data (\code{y}) is padded via reflection at the start and the end to a distance of twice the maximum period. The padded data and the filter are passed to \code{\link{filtfilt}} after which the data are unpadded and returned. + + The argumement \code{\var{W}} can be given in either frequency between 0 and 0.5 or, for convenience, period (minimum value of 2). For low-pass and high-pass filters, \code{\var{W}} must have a length of one. For low-pass and high-pass filters \code{\var{W}} must be a two-element vector (\code{c(low, high)}) specifying the lower and upper boundaries of the filter. + + Because this is just a wrapper for a tree-ring package, the frequencies and periods assume a sampling frequency of one. Users are encouraged to build their own filters using the \code{signal} package. + +} + +\value{ + A filtered vector. +} + +\author{ + Andy Bunn. Patched and improved by Mikko Korpela. +} + +\seealso{ \code{\link{hanning}}, \code{\link{detrend}} } + +\examples{ +data("co021") +x <- na.omit(co021[,1]) +# 20-year low-pass filter +xSm <- pass.filt(x,W=0.05,type="low") +plot(x,type="l",col="grey") +lines(xSm,col="red") + +# 20-year high-pass filter +xSm <- pass.filt(x,W=20,type="high") +plot(scale(x),type="l",col="grey") +lines(scale(xSm),col="red") + +# 20 to 100-year band-pass filter +xSm <- pass.filt(x,W=c(0.01,0.05),type="pass") +plot(x,type="l",col="grey") +lines(xSm,col="red") +# odd that "pass" has a mean of zero when others have mean of x. +lines(xSm+mean(x),col="blue") + +# 20 to 100-year stop-pass filter +xSm <- pass.filt(x,W=c(20,100),type="stop") +plot(x,type="l",col="grey") +lines(xSm,col="red") +} +\keyword{ smooth } Property changes on: pkg/dplR/man/pass.filt.Rd ___________________________________________________________________ Added: svn:eol-style + native From noreply at r-forge.r-project.org Mon Jun 18 07:49:05 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 18 Jun 2018 07:49:05 +0200 (CEST) Subject: [Dplr-commits] r1116 - in pkg/dplR: . man Message-ID: <20180618054905.22FDC180992@r-forge.r-project.org> Author: andybunn Date: 2018-06-18 07:49:04 +0200 (Mon, 18 Jun 2018) New Revision: 1116 Modified: pkg/dplR/DESCRIPTION pkg/dplR/man/detrend.series.Rd Log: typos etc. Modified: pkg/dplR/DESCRIPTION =================================================================== --- pkg/dplR/DESCRIPTION 2018-06-18 05:20:36 UTC (rev 1115) +++ pkg/dplR/DESCRIPTION 2018-06-18 05:49:04 UTC (rev 1116) @@ -24,7 +24,7 @@ Matrix (>= 1.0-3), digest (>= 0.2.3), matrixStats (>= 0.50.2), png (>= 0.1-2), R.utils (>= 1.32.1), stringi (>= 0.2-3), stringr (>= 0.4), XML (>= 2.1-0), plyr (>= 1.8), animation (>= - 2.0-2) + 2.0-2), signal Suggests: Biobase, Cairo (>= 1.5-0), dichromat (>= 1.2-3), foreach, forecast (>= 3.6), gmp (>= 0.5-5), iterators, knitr, RColorBrewer, testthat (>= 0.8), tikzDevice, waveslim Modified: pkg/dplR/man/detrend.series.Rd =================================================================== --- pkg/dplR/man/detrend.series.Rd 2018-06-18 05:20:36 UTC (rev 1115) +++ pkg/dplR/man/detrend.series.Rd 2018-06-18 05:49:04 UTC (rev 1116) @@ -253,18 +253,22 @@ # stiffness to 50 years (which is not neccesarily a good choice!) series.rwi <- detrend.series(y = series, y.name = "CAM011", method="Spline",nyrs=50) + # note that method "Ar" doesn't get plotted in first panel # since this approach doesn't approximate a growth curve. series.rwi <- detrend.series(y = series, y.name = "CAM011", method="Ar") + # note the difference between ModNegExp and ModHugershoff at the -# start of the series +# start of the series. Also notice how curves, etc. are returned +# via return.info data(co021) series <- co021[, 4] names(series) <- rownames(co021) series.rwi <- detrend.series(y = series, y.name = names(co021)[4], method=c("ModNegExp", "ModHugershoff"), - verbose = T, return.info = T, make.plot = T) + verbose = TRUE, return.info = TRUE, + make.plot = TRUE) } \keyword{ manip } From noreply at r-forge.r-project.org Mon Jun 18 18:48:56 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 18 Jun 2018 18:48:56 +0200 (CEST) Subject: [Dplr-commits] r1117 - in pkg/dplR: R man Message-ID: <20180618164856.86BCB189DD6@r-forge.r-project.org> Author: andybunn Date: 2018-06-18 18:48:56 +0200 (Mon, 18 Jun 2018) New Revision: 1117 Modified: pkg/dplR/R/pass.filt.R pkg/dplR/man/detrend.series.Rd pkg/dplR/man/pass.filt.Rd Log: work on filter methods Modified: pkg/dplR/R/pass.filt.R =================================================================== --- pkg/dplR/R/pass.filt.R 2018-06-18 05:49:04 UTC (rev 1116) +++ pkg/dplR/R/pass.filt.R 2018-06-18 16:48:56 UTC (rev 1117) @@ -1,4 +1,6 @@ -pass.filt <- function(y,W,type=c("low", "high", "stop", "pass"),n=4){ +pass.filt <- function(y,W,type=c("low", "high", "stop", "pass"), + method = c("Butterworth","ChebyshevI"), + n=4, Rp = 1){ if(any(is.na(y))) stop("y contains NA") # check W's length @@ -21,17 +23,29 @@ # sort f in case it's passed in bcakwards f <- sort(f) + + method <- method[1] - # initialize the butterworth filter - bFilt <- signal::butter(n=n, W=f*2, type=type, plane="z") + if(method == "ChebyshevI"){ + filt <- signal::cheby1(n=n, W=f*2, type = type, Rp=Rp, plane = "z") + } + else { + filt <- signal::butter(n=n, W=f*2, type=type, plane="z") + } + + # remove mean + yAvg <- mean(y) + y <- y - yAvg + # pad the data to twice the max period pad <- max(p) * 2 ny <- length(y) # pad the data yPad <- c(y[pad:1],y,y[ny:(ny-pad)]) # run the filter - yFilt <- signal::filtfilt(bFilt, yPad) - # unpad the filtered data and return + yFilt <- signal::filtfilt(filt, yPad) + # unpad the filtered data yFilt <- yFilt[(pad+1):(ny+pad)] - yFilt + # return with mean added back in + yFilt + yAvg } Modified: pkg/dplR/man/detrend.series.Rd =================================================================== --- pkg/dplR/man/detrend.series.Rd 2018-06-18 05:49:04 UTC (rev 1116) +++ pkg/dplR/man/detrend.series.Rd 2018-06-18 16:48:56 UTC (rev 1117) @@ -8,7 +8,8 @@ } \usage{ detrend.series(y, y.name = "", make.plot = TRUE, - method = c("Spline", "ModNegExp", "Mean", "Ar", "Friedman", "ModHugershoff"), + method = c("Spline", "ModNegExp", + "Mean", "Ar", "Friedman", "ModHugershoff"), nyrs = NULL, f = 0.5, pos.slope = FALSE, constrain.nls = c("never", "when.fail", "always"), verbose = FALSE, return.info = FALSE, Modified: pkg/dplR/man/pass.filt.Rd =================================================================== --- pkg/dplR/man/pass.filt.Rd 2018-06-18 05:49:04 UTC (rev 1116) +++ pkg/dplR/man/pass.filt.Rd 2018-06-18 16:48:56 UTC (rev 1117) @@ -6,21 +6,26 @@ Applies low-pass, high-pass, band-pass, or stop-pass filtering to \code{\var{y}} with frequencies (or periods) supplied by the user. } \usage{ -pass.filt(y, W, type=c("low", "high", "stop", "pass"), n=4) +pass.filt(y,W,type=c("low", "high", "stop", "pass"), + method = c("Butterworth","ChebyshevI"), + n=4, Rp = 1) } \arguments{ \item{y}{ a \code{numeric} vector, typically a tree-ring series. } \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{n}{ a \code{numeric} value giving the order of the Butterworth filter. } + \item{method}{ a \code{character} specifying indicating whether to use a Butterworth or a type I Chebyshev filter.} + \item{Rp}{ a \code{numeric} value giving the dB for the passband ripple. } } \details{ - This function applies a Butterworth filter of order \code{\var{n}} to a signal and is nothing more than a wrapper for two functions in the \code{signal} package: \code{\link{butter}} and \code{\link{filtfilt}}. In this function, a Butterworth filter is initialized with the arguments given. The input data (\code{y}) is padded via reflection at the start and the end to a distance of twice the maximum period. The padded data and the filter are passed to \code{\link{filtfilt}} after which the data are unpadded and returned. + This function applies either a Butterworth or a Chebyshev type I filter of order \code{\var{n}} to a signal and is nothing more than a wrapper for functions in the \code{signal} package. The filters are dsigned via \code{\link{butter}} and \code{\link{cheby1}}. The filter is applied via \code{\link{filtfilt}}. + The input data (\code{y}) has the mean value subtracted and is then padded via reflection at the start and the end to a distance of twice the maximum period. The padded data and the filter are passed to \code{\link{filtfilt}} after which the data are unpadded and returned afer the mean is added back. + The argumement \code{\var{W}} can be given in either frequency between 0 and 0.5 or, for convenience, period (minimum value of 2). For low-pass and high-pass filters, \code{\var{W}} must have a length of one. For low-pass and high-pass filters \code{\var{W}} must be a two-element vector (\code{c(low, high)}) specifying the lower and upper boundaries of the filter. - Because this is just a wrapper for a tree-ring package, the frequencies and periods assume a sampling frequency of one. Users are encouraged to build their own filters using the \code{signal} package. + Because this is just a wrapper for casual use with tree-ring data the frequencies and periods assume a sampling frequency of one. Users are encouraged to build their own filters using the \code{signal} package. } @@ -37,26 +42,29 @@ \examples{ data("co021") x <- na.omit(co021[,1]) -# 20-year low-pass filter -xSm <- pass.filt(x,W=0.05,type="low") + +# 20-year low-pass filter -- note freq is passed in +bSm <- pass.filt(x,W=0.05,type="low",method="Butterworth") +cSm <- pass.filt(x,W=0.05,type="low",method="ChebyshevI") plot(x,type="l",col="grey") -lines(xSm,col="red") +lines(bSm,col="red") +lines(cSm,col="blue") -# 20-year high-pass filter -xSm <- pass.filt(x,W=20,type="high") -plot(scale(x),type="l",col="grey") -lines(scale(xSm),col="red") +# 20-year high-pass filter -- note period is passed in +bSm <- pass.filt(x,W=20,type="high") +plot(x,type="l",col="grey") +lines(bSm,col="red") -# 20 to 100-year band-pass filter -xSm <- pass.filt(x,W=c(0.01,0.05),type="pass") +# 20 to 100-year band-pass filter -- note freqs are passed in +bSm <- pass.filt(x,W=c(0.01,0.05),type="pass") +cSm <- pass.filt(x,W=c(0.01,0.05),type="pass",method="ChebyshevI") plot(x,type="l",col="grey") -lines(xSm,col="red") -# odd that "pass" has a mean of zero when others have mean of x. -lines(xSm+mean(x),col="blue") +lines(bSm,col="red") +lines(cSm,col="blue") -# 20 to 100-year stop-pass filter -xSm <- pass.filt(x,W=c(20,100),type="stop") +# 20 to 100-year stop-pass filter -- note periods are passed in +cSm <- pass.filt(x,W=c(20,100),type="stop",method="ChebyshevI") plot(x,type="l",col="grey") -lines(xSm,col="red") +lines(cSm,col="red") } \keyword{ smooth } From noreply at r-forge.r-project.org Tue Jun 19 03:23:43 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 19 Jun 2018 03:23:43 +0200 (CEST) Subject: [Dplr-commits] r1118 - in pkg/dplR: R man Message-ID: <20180619012343.B6ABE18AD92@r-forge.r-project.org> Author: andybunn Date: 2018-06-19 03:23:42 +0200 (Tue, 19 Jun 2018) New Revision: 1118 Modified: pkg/dplR/R/powt.R pkg/dplR/man/powt.Rd Log: making powt return class rwl as well as data.frame Modified: pkg/dplR/R/powt.R =================================================================== --- pkg/dplR/R/powt.R 2018-06-18 16:48:56 UTC (rev 1117) +++ pkg/dplR/R/powt.R 2018-06-19 01:23:42 UTC (rev 1118) @@ -44,5 +44,7 @@ } prec <- getprec(rwl) xt <- lapply(rwl, FUN = transf) - data.frame(xt, row.names = row.names(rwl), check.names = FALSE) + res <- data.frame(xt, row.names = row.names(rwl), check.names = FALSE) + class(res) <- c("rwl","data.frame") + res } Modified: pkg/dplR/man/powt.Rd =================================================================== --- pkg/dplR/man/powt.Rd 2018-06-18 16:48:56 UTC (rev 1117) +++ pkg/dplR/man/powt.Rd 2018-06-19 01:23:42 UTC (rev 1118) @@ -14,7 +14,10 @@ produced by \code{\link{read.rwl}} or \code{\link{read.fh}}} } \value{ - A \code{data.frame} containing the power transformed ring width series. + An object of class \code{c("rwl", "data.frame")} containing the power + transformed ring width series 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. } \details{ This procedure is a variance stabilization technique implemented after @@ -37,6 +40,8 @@ \examples{library(utils) data(gp.rwl) gp.pt <- powt(gp.rwl) +hist(summary(gp.rwl)$skew) +hist(summary(gp.pt)$skew) } \author{ Christian Zang. Patched and improved by Mikko Korpela. From noreply at r-forge.r-project.org Wed Jun 20 22:12:40 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 20 Jun 2018 22:12:40 +0200 (CEST) Subject: [Dplr-commits] r1119 - in pkg/dplR: . R man Message-ID: <20180620201240.14B07181457@r-forge.r-project.org> 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 } From noreply at r-forge.r-project.org Fri Jun 22 21:46:33 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 22 Jun 2018 21:46:33 +0200 (CEST) Subject: [Dplr-commits] r1120 - in pkg/dplR: . R man Message-ID: <20180622194633.DCBF2187B8A@r-forge.r-project.org> Author: andybunn Date: 2018-06-22 21:46:33 +0200 (Fri, 22 Jun 2018) New Revision: 1120 Added: pkg/dplR/R/sss.R pkg/dplR/man/sss.Rd Modified: pkg/dplR/ChangeLog pkg/dplR/NAMESPACE pkg/dplR/man/rwi.stats.running.Rd Log: Adding sss as a new function. Modified: pkg/dplR/ChangeLog =================================================================== --- pkg/dplR/ChangeLog 2018-06-20 20:12:39 UTC (rev 1119) +++ pkg/dplR/ChangeLog 2018-06-22 19:46:33 UTC (rev 1120) @@ -1,5 +1,10 @@ * CHANGES IN dplR VERSION 1.6.9 +File: sss.R and .Rd +---------------- + +- Adding subsample signal strength as a stand alone function + File: spag.plot.R and .Rd ---------------- @@ -29,7 +34,7 @@ File: rwl.stats.R and .Rd ---------------- -- Removing sens1 and sens2 from this function. At world dendro I'm still seeing these being used by dplR users. It's a terrible stat. I'm taking it out. Help file ammended. +- Removing sens1 and sens2 from this function. At world dendro I'm still seeing these being used by dplR users. It's a terrible stat. I'm taking it out. Help file amended. File: detrend.series.R and .Rd ---------------- Modified: pkg/dplR/NAMESPACE =================================================================== --- pkg/dplR/NAMESPACE 2018-06-20 20:12:39 UTC (rev 1119) +++ pkg/dplR/NAMESPACE 2018-06-22 19:46:33 UTC (rev 1120) @@ -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,as.rwl) + plotRings,time.rwl,time.crn,csv2rwl,pass.filt,as.rwl,sss) S3method(print, redfit) S3method(plot, rwl) Added: pkg/dplR/R/sss.R =================================================================== --- pkg/dplR/R/sss.R (rev 0) +++ pkg/dplR/R/sss.R 2018-06-22 19:46:33 UTC (rev 1120) @@ -0,0 +1,37 @@ +sss <- function(rwi,ids=NULL){ + # rwi.stats is robust enough to have a single call regardless of + # whether ids is passed in because if no ids are passed in + # rbar.eff == rbar.bt and n.cores=n.trees + # Thus, if ids is NULL assume one core / tree use and + # we use rbar.bt (which is the same as rbar.eff). If there are ids + # we use rbar.eff which is not the same as rbar.bt. Ditto for getting + # N. Satisfy yourself via: + #ca533.rwi <- detrend(ca533,method="Spline") + #ca533.ids <- autoread.ids(ca533) + #rwi.stats(ca533.rwi) + #rwi.stats(ca533.rwi,ca533.ids) + + rwiVars <- rwi.stats(rwi, ids=ids) + rbar <- rwiVars$rbar.eff + N <- rwiVars$n.trees + + + if(is.null(ids)){ + # n is is the number of cores in subsample + n <- rowSums(!is.na(rwi)) + } + else { + # n is the number of trees in the subsample. + # calculating n is kind of tedious: + # we need n trees, not n cores in a year + colnames.rwi <- colnames(rwi) + n <- rep(NA,nrow(rwi)) + for(i in 1:nrow(rwi)){ + cols.with.data <- c(!is.na(rwi[i,])) + trees.this.year <- ids$tree[rownames(ids) %in% colnames.rwi[cols.with.data]] + n[i] <- length(unique(trees.this.year)) + } + } + res <- (n*(1+(N-1)*rbar)) / (N*(1+(n-1)*rbar)) + res +} Property changes on: pkg/dplR/R/sss.R ___________________________________________________________________ Added: svn:eol-style + native Modified: pkg/dplR/man/rwi.stats.running.Rd =================================================================== --- pkg/dplR/man/rwi.stats.running.Rd 2018-06-20 20:12:39 UTC (rev 1119) +++ pkg/dplR/man/rwi.stats.running.Rd 2018-06-22 19:46:33 UTC (rev 1120) @@ -132,6 +132,8 @@ Fritts (2001) for further details for computational details on the output. The signal-to-noise ratio is calculated following Cook and Pederson (2011). + + Note that Buras (2017) cautions against using the expressed population signal as a statistic to determine the whether a chronology correctly represents the population signal of a data set. He reccomends the use of subsample signal strength (\code{\link{sss}}) over EPS. If desired, the \code{\var{rwi}} can be filtered in the same manner as the family of cross-dating functions using \code{\var{prewhiten}} and @@ -198,6 +200,8 @@ } \references{ + Buras, A. (2017) A comment on the Expressed Population Signal. Dendrochronologia 44:130-132. + Cook, E. R. and Kairiukstis, L. A., editors (1990) \emph{Methods of Dendrochronology: Applications in the Environmental Sciences}. Springer. \acronym{ISBN-13}: 978-0-7923-0586-6. @@ -236,51 +240,5 @@ rwi.stats(gp.rwi, gp.ids, period="common") rwi.stats.legacy(gp.rwi, gp.ids) # rwi.stats prior to dplR 1.5.3 -\dontrun{ - library(graphics) - def.par <- par(no.readonly=TRUE) - ## Plot the chronology showing a potential cutoff year based on EPS - eps.cut <- 0.92 # An arbitrary EPS cutoff for demonstration - gp.crn <- chron(gp.rwi) - ## Running stats on the rwi with an window - foo <- rwi.stats.running(gp.rwi, gp.ids, window.length = 80) - yrs <- time(gp.crn) - bar <- data.frame(yrs = c(min(yrs), foo$mid.year, max(yrs)), - eps = c(NA, foo$eps, NA)) - par(mar = c(2, 2, 2, 2), mgp = c(1.1, 0.1, 0), tcl = 0.25, - mfcol = c(2, 1), xaxs='i') - plot(yrs, gp.crn[, 1], type = "n", xlab = "Year", - ylab = "RWI", axes=FALSE) - cutoff <- max(bar$yrs[bar$eps < eps.cut], na.rm = TRUE) - xx <- c(500, 500, cutoff, cutoff) - yy <- c(-1, 3, 3, -1) - polygon(xx, yy, col = "grey80") - abline(h = 1, lwd = 1.5) - lines(yrs, gp.crn[, 1], col = "grey50") - lines(yrs, ffcsaps(gp.crn[, 1], nyrs = 32), col = "red", lwd = 2) - axis(1); axis(2); axis(3); - par(new = TRUE) - ## Add EPS - plot(bar$yrs, bar$eps, type = "b", xlab = "", ylab = "", - axes = FALSE, pch = 20, col = "blue") - axis(4, at = pretty(foo$eps)) - mtext("EPS", side = 4, line = 1.1) - box() - ## Second plot is the chronology after the cutoff only - ## Chronology is rebuilt using just years after cutoff but - ## that difference is essentially nil. - yr.mask <- yrs > cutoff - yrs2 <- yrs[yr.mask] - gp.crn2 <- chron(gp.rwi[yr.mask, ]) - plot(yrs2, gp.crn2[, 1], type = "n", - xlab = "Year", ylab = "RWI", axes=FALSE) - abline(h = 1, lwd = 1.5) - lines(yrs2, gp.crn2[, 1], col = "grey50") - lines(yrs2, ffcsaps(gp.crn2[, 1], nyrs = 32), - col = "red", lwd = 2) - axis(1); axis(2); axis(3); axis(4) - box() - par(def.par) } -} \keyword{ misc } Added: pkg/dplR/man/sss.Rd =================================================================== --- pkg/dplR/man/sss.Rd (rev 0) +++ pkg/dplR/man/sss.Rd 2018-06-22 19:46:33 UTC (rev 1120) @@ -0,0 +1,96 @@ +\encoding{UTF-8} +\name{sss} +\alias{sss} +\title{ Subsample Signal Strength } +\description{ + Calculate subsample signal strength on a + \code{data.frame} of (usually) ring-width indices. +} +\usage{ +sss(rwi, ids = NULL) +} +\arguments{ + + \item{rwi}{ a \code{data.frame} with detrended and standardized ring + width indices as columns and years as rows such as that produced by + \code{\link{detrend}}. } + + \item{ids}{ an optional \code{data.frame} with column one named + \code{"tree"} giving a \code{numeric} \acronym{ID} for each tree and + column two named \code{"core"} giving a \code{numeric} \acronym{ID} + for each core. Defaults to one core per tree as\cr + \code{data.frame(tree=1:ncol(\var{rwi}), core=rep(1, ncol(\var{rwi})))}. } +} +\details{ + This calculates subsample signal strength (sss) following equation 3.50 in Cook and Kairiukstis (1990) but using notation from Buras (2017) because writing the prime unicode symbol seems too difficult. The function calls \code{\link{rwi.stats}} and passes it the arguments \code{ids} and \code{prewhiten}. + + To make better use of variation in growth within and between series, an appropriate mask (parameter \code{\var{ids}}) should be provided that identifies each series with a tree as it is common for dendrochronologists to take more than one core per tree. The function \code{\link{read.ids}} is helpful for creating a mask based on the series \acronym{ID}. + + Subsample signal strength is calculated as \eqn{\frac{n[1+(N-1)\bar{r}]}{N[1+(n-1)\bar{r}]}}{n*(1+(N-1)*rbar) / N*(1+(n-1)*rbar)} where \code{n} and \code{N} are the number of cores or trees in the subsample and sample respectively and \code{rbar} is mean interseries correlation. If there is only one core per tree \code{n} is the sample depth in a given year (\code{rowSums(!is.na(rwi))}), \code{N} is the number of cores (\code{n.cores} as given by \code{\link{rwi.stats}}), and \code{rbar} is the mean interseries correlation between all series (\code{r.bt} as given by \code{\link{rwi.stats}}). If there are multiple cores per tree \code{n} is the number of trees present in a given year, \code{N} is the number of trees (\code{n.trees} as given by \code{\link{rwi.stats}}), and \code{rbar} is the effective mean interseries correlation (\code{r.eff} as given by \code{\link{rwi.stats}}). + +Readers interested in the differences between subsample signal strength and the more commonly used (running) expressed population signal should look at Buras (2017) on the common misuse of the expressed population signal as well as Cook and Pederson (2011) for a more general appraoch to categorizing variability in tree-ring data. + +} + +\value{ A \code{numeric} containing the subsample signal strength that is the same as number if rows of\code{rwi}. +} +\references{ + + Buras, A. (2017) A comment on the Expressed Population Signal. Dendrochronologia 44:130-132. + + Cook, E. R. and Kairiukstis, L. A., editors (1990) \emph{Methods of + Dendrochronology: Applications in the Environmental Sciences}. + Springer. \acronym{ISBN-13}: 978-0-7923-0586-6. + + Cook, E. R. and Pederson, N. (2011) Uncertainty, Emergence, and + Statistics in Dendrochronology. In Hughes, M. K., Swetnam, T. W., and + Diaz, H. F., editors, \emph{Dendroclimatology: Progress and + Prospects}, pages 77\enc{?}{--}112. Springer. \acronym{ISBN-13}: + 978-1-4020-4010-8. + +} + +\author{Andy Bunn. Patched and improved by Mikko Korpela. } +\seealso{ \code{\link{rwi.stats}}, \code{\link{read.ids}} } +\examples{ +data(ca533) +ca533.rwi <- detrend(ca533,method="Spline") +# assuming 1 core / tree +ca533.sss <- sss(ca533.rwi) + +ca533.ids <- autoread.ids(ca533) +# done properly with >=1 core / tree as per the ids +ca533.sss2 <- sss(ca533.rwi,ca533.ids) + +yr <- time(ca533) +plot(yr,ca533.sss,type="l",ylim=c(0.4,1), + col="darkblue",lwd=2,xlab="Year",ylab="SSS") +lines(yr,ca533.sss2,lty="dashed", + col="darkgreen",lwd=2) + +# Plot the chronology showing a potential cutoff year based on SSS +ca533.crn <- chron(ca533.rwi) +def.par <- par(no.readonly=TRUE) +par(mar = c(2, 2, 2, 2), mgp = c(1.1, 0.1, 0), tcl = 0.25, xaxs='i') +plot(yr, ca533.crn[, 1], type = "n", xlab = "Year", + ylab = "RWI", axes=FALSE) +cutoff <- max(yr[ca533.sss2 < 0.85]) +xx <- c(500, 500, cutoff, cutoff) +yy <- c(-1, 3, 3, -1) +polygon(xx, yy, col = "grey80") +abline(h = 1, lwd = 1.5) +lines(yr, ca533.crn[, 1], col = "grey50") +lines(yr, ffcsaps(ca533.crn[, 1], nyrs = 32), col = "red", lwd = 2) +axis(1); axis(2); axis(3); +par(new = TRUE) +## Add EPS +plot(yr, ca533.sss2, type = "l", xlab = "", ylab = "", + axes = FALSE, col = "blue") +abline(h=0.85,col="blue",lty="dashed") +axis(4, at = pretty(ca533.sss2)) +mtext("SSS", side = 4, line = 1.1, lwd=1.5) +box() +par(def.par) + +} +\keyword{ misc } Property changes on: pkg/dplR/man/sss.Rd ___________________________________________________________________ Added: svn:eol-style + native From noreply at r-forge.r-project.org Fri Jun 22 23:56:01 2018 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 22 Jun 2018 23:56:01 +0200 (CEST) Subject: [Dplr-commits] r1121 - pkg/dplR/vignettes Message-ID: <20180622215601.B241A1878AC@r-forge.r-project.org> Author: andybunn Date: 2018-06-22 23:56:01 +0200 (Fri, 22 Jun 2018) New Revision: 1121 Modified: pkg/dplR/vignettes/chron-dplR.Rnw Log: swtiched eps threshold to sss Modified: pkg/dplR/vignettes/chron-dplR.Rnw =================================================================== --- pkg/dplR/vignettes/chron-dplR.Rnw 2018-06-22 19:46:33 UTC (rev 1120) +++ pkg/dplR/vignettes/chron-dplR.Rnw 2018-06-22 21:56:01 UTC (rev 1121) @@ -171,22 +171,20 @@ the chronology as in Figure~\ref{fig:crn.plot.sd}. A more interesting and likely more robust approach is to truncate via the -expressed population signal (EPS). The result is plotted in +subsample signal strength (SSS). The result is plotted in Figure~\ref{fig:crn.plot.eps}. <>= wa082.ids <- autoread.ids(wa082) -eps.cut <- 0.75 # An arbitrary EPS cutoff for demonstration -wa082.rwi.stats <- rwi.stats.running(wa082.rwi, wa082.ids, window.length = 30) +sss.cut <- 0.85 +wa082.sss <- sss(wa082.rwi, wa082.ids) yrs <- time(wa082.crn) -bar <- data.frame(yrs = c(min(yrs), wa082.rwi.stats$mid.year, max(yrs)), - eps = c(NA, wa082.rwi.stats$eps, NA)) op <- par(no.readonly=TRUE) par(mar = c(2, 2, 2, 2), mgp = c(1.1, 0.1, 0), tcl = 0.25, mfcol = c(2, 1), xaxs='i') plot(yrs, wa082.crn[, 1], type = "n", xlab = "Year", ylab = "RWI", axes=FALSE) -cutoff <- max(bar$yrs[bar$eps < eps.cut], na.rm = TRUE) +cutoff <- max(yrs[wa082.sss < 0.85]) xx <- c(500, 500, cutoff, cutoff) yy <- c(-1, 3, 3, -1) polygon(xx, yy, col = "grey80") @@ -196,23 +194,25 @@ axis(1); axis(2); axis(3); par(new = TRUE) ## Add EPS -plot(bar$yrs, bar$eps, type = "b", xlab = "", ylab = "", - axes = FALSE, pch = 20, col = "blue") -axis(4, at = pretty(wa082.rwi.stats$eps)) -mtext("EPS", side = 4, line = 1.1) +plot(yrs, wa082.sss, type = "l", xlab = "", ylab = "", + axes = FALSE, col = "blue") +abline(h=0.85,col="blue",lty="dashed") +axis(4, at = pretty(wa082.sss)) +mtext("SSS", side = 4, line = 1.1) box() ## Second plot is the chronology after the cutoff only ## Chronology is rebuilt using just years after cutoff but -## that difference is essentially nil. +## the difference by doing it this way rather than just truncating +## is essentially nil. yr.mask <- yrs > cutoff yrs2 <- yrs[yr.mask] wa082.rwi2 <- detrend(wa082[yr.mask, ], method="Spline") -wa082.crn.eps <- chron(wa082.rwi2) -plot(yrs2, wa082.crn.eps[, 1], type = "n", +wa082.crn2 <- chron(wa082.rwi2) +plot(yrs2, wa082.crn2[, 1], type = "n", xlab = "Year", ylab = "RWI", axes=FALSE) abline(h = 1, lwd = 1.5) -lines(yrs2, wa082.crn.eps[, 1], col = "grey50") -lines(yrs2, ffcsaps(wa082.crn.eps[, 1], nyrs = 30), +lines(yrs2, wa082.crn2[, 1], col = "grey50") +lines(yrs2, ffcsaps(wa082.crn2[, 1], nyrs = 30), col = "red", lwd = 2) axis(1); axis(2); axis(3); axis(4) box()