diff --git a/ChangeLog b/ChangeLog index 86b195c..69b942d 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,57 @@ +* CHANGES IN dplR VERSION 1.8.0 + +File: helpers.R, NAMESPACE +-------------------------- + - Added check.rwl(), a new exported function that validates an object as + a proper rwl. If the input is not already class "rwl", coercion is + attempted via as.rwl(): on success a warning is issued; on failure a + single informative error is raised that describes both the class + problem and the structural reason coercion failed. After class + validation, check.rwl() warns about any internal NA values (NAs + sandwiched between real values within a series) and names the affected + series, directing the user to fill.internal.NA(). + +File: as.rwl.R +-------------- + - Added a check that all columns are numeric. Previously as.rwl() would + accept a data.frame with character columns and silently assign the rwl + class to an invalid object. + +File: bai.in.R, bai.out.R, ccf.series.rwl.R, cms.R, common.interval.R, + corr.rwl.seg.R, corr.series.seg.R, detrend.R, i.detrend.R, + interseries.cor.R, pointer.R, rcs.R, rwl.stats.R, seg.plot.R, + series.rwl.plot.R, spag.plot.R, ssf.R, strip.rwl.R, + xdate.floater.R +----------------------------------------------------------------------- + - Replaced ad-hoc rwl validation (bare is.data.frame() checks or + warning-only class checks) with check.rwl() at the top of each + function, providing uniform, informative validation across all + public functions that accept an rwl object. + +File: sgc.R, sgc.Rd +-------------------- + - Renamed the first argument from x to rwl for consistency with the + rest of the package. Updated documentation accordingly. + +File: chron.R, chron.Rd +------------------------ + - Renamed the first argument from x to rwi to correctly reflect that + chron() expects detrended ring-width indices, not raw ring widths. + Updated documentation accordingly. + +File: chron.ars.R, chron.ars.Rd +--------------------------------- + - Renamed the first argument from x to rwi for the same reason as + chron(). Inner helper functions (pooledAR, postAR, prewhitenAR, + prewhitenARIMA) retain their own local x arguments, which are + unchanged. Updated documentation accordingly. + +File: tests/testthat/test-check.rwl.R +-------------------------------------- + - Added 17 new tests covering check.rwl() and as.rwl(): happy path, + coercion with warning, structural failure messages, internal NA + detection, and all as.rwl() error conditions. + * CHANGES IN dplR VERSION 1.7.9 File: chron.ars.R diff --git a/R/chron.R b/R/chron.R index 4000993..44a4015 100644 --- a/R/chron.R +++ b/R/chron.R @@ -1,20 +1,19 @@ `chron` <- - function(x, biweight=TRUE, prewhiten=FALSE, ...) + function(rwi, biweight=TRUE, prewhiten=FALSE, ...) { check.flags(biweight, prewhiten) - x <- check.rwl(x) - samps <- rowSums(!is.na(x)) + samps <- rowSums(!is.na(rwi)) if (!biweight) { - std <- rowMeans(x, na.rm=TRUE) + std <- rowMeans(rwi, na.rm=TRUE) } else { - std <- apply(x, 1, tbrm, C=9) + std <- apply(rwi, 1, tbrm, C=9) } if (prewhiten) { - x.ar <- apply(x, 2, ar.func, ...) + rwi.ar <- apply(rwi, 2, ar.func, ...) if (!biweight) { - res <- rowMeans(x.ar, na.rm=TRUE) + res <- rowMeans(rwi.ar, na.rm=TRUE) } else { - res <- apply(x.ar, 1, tbrm, C=9) + res <- apply(rwi.ar, 1, tbrm, C=9) } res[is.nan(res)] <- NA out <- data.frame(std, res, samps) @@ -25,7 +24,7 @@ out <- data.frame(std, samps) names(out) <- c("std", "samp.depth") } - row.names(out) <- row.names(x) + row.names(out) <- row.names(rwi) class(out) <- c("crn", "data.frame") out } diff --git a/R/chron.ars.R b/R/chron.ars.R index e973e36..609c44a 100644 --- a/R/chron.ars.R +++ b/R/chron.ars.R @@ -1,4 +1,4 @@ -`chron.ars` <- function(x, biweight=TRUE, maxLag=10, +`chron.ars` <- function(rwi, biweight=TRUE, maxLag=10, firstAICmin=TRUE, verbose = TRUE, prewhitenMethod=c("ar.yw","arima.CSS-ML")){ # helpers @@ -182,19 +182,17 @@ prewhitenMethod2 <- match.arg(arg = prewhitenMethod, choices = known.prewhitenMethods, several.ok = FALSE) - x <- check.rwl(x) + samps <- rowSums(!is.na(rwi)) - samps <- rowSums(!is.na(x)) - # calc std chronology if(!biweight) { - stdCrn <- rowMeans(x, na.rm=TRUE) + stdCrn <- rowMeans(rwi, na.rm=TRUE) } else { - stdCrn <- apply(x, 1, tbrm, C=9) + stdCrn <- apply(rwi, 1, tbrm, C=9) } - + ### Get the pooled ACF and AR coefs from the RWI - outAR <- pooledAR(x,firstAICmin = firstAICmin, maxLag = maxLag) + outAR <- pooledAR(rwi, firstAICmin = firstAICmin, maxLag = maxLag) # model order p <- outAR$orderOut # do some verbose output here @@ -212,10 +210,10 @@ ### Prewhiten each RWI series individually using the model order if(prewhitenMethod2 == "ar.yw") { - RWIclean <- apply(x,2,prewhitenAR,p=p) + RWIclean <- apply(rwi, 2, prewhitenAR, p=p) } if(prewhitenMethod2 == "arima.CSS-ML") { - RWIclean <- apply(x,2,prewhitenARIMA,p=p) + RWIclean <- apply(rwi, 2, prewhitenARIMA, p=p) } @@ -257,7 +255,7 @@ out <- data.frame(std=stdCrn,res=resCrn, ars=arsCrn,samp.depth=samps) - row.names(out) <- row.names(x) + row.names(out) <- row.names(rwi) class(out) <- c("crn", "data.frame") return(out) } \ No newline at end of file diff --git a/R/helpers.R b/R/helpers.R index 34f901e..6dc51a3 100644 --- a/R/helpers.R +++ b/R/helpers.R @@ -441,9 +441,16 @@ find.internal.na <- function(x) { ### Called at the top of every public function that takes rwl. check.rwl <- function(rwl) { if (!inherits(rwl, "rwl")) { - warning("'rwl' is not class \"rwl\". Attempting to coerce.", + rwl <- tryCatch( + as.rwl(rwl), + error = function(e) { + stop("'rwl' is not class \"rwl\" and coercion failed: ", + conditionMessage(e), call. = FALSE) + } + ) + # only reached if coercion succeeded + warning("'rwl' is not class \"rwl\". Coerced successfully.", call. = FALSE) - rwl <- as.rwl(rwl) # stops with a clear message if structure is wrong } # Check for internal NAs per series, warn strongly if found has.internal.na <- vapply(rwl, function(x) any(find.internal.na(x) != 0), diff --git a/R/sgc.R b/R/sgc.R index b85cd2a..a944f5e 100644 --- a/R/sgc.R +++ b/R/sgc.R @@ -1,9 +1,9 @@ -`sgc` <- - function(x, overlap = 50, prob = TRUE) +`sgc` <- + function(rwl, overlap = 50, prob = TRUE) { # checks class rwl and correct overlap - x <- check.rwl(x) - if(any(length(overlap)!=1 | !is.numeric(overlap) | + rwl <- check.rwl(rwl) + if(any(length(overlap)!=1 | !is.numeric(overlap) | overlap%%1!=0 | overlap < 3)){ stop("'overlap' should be a single integer >=3") } @@ -14,14 +14,14 @@ stop("'prob' must be either TRUE (the default) or FALSE") } # function starts here - n <- dim(x)[2] + n <- dim(rwl)[2] sgc_mat <- matrix(NA_real_, nrow = n, ncol = n) ssgc_mat <- matrix(NA_real_, nrow = n, ncol = n) overlap_n <- matrix(NA_real_, nrow = n, ncol = n) - rownames(sgc_mat) <- colnames(sgc_mat) <- names(x) - rownames(ssgc_mat) <- colnames(ssgc_mat) <- names(x) - rownames(overlap_n) <- colnames(overlap_n) <- names(x) - treering_sign <- apply(x, 2, diff) + rownames(sgc_mat) <- colnames(sgc_mat) <- names(rwl) + rownames(ssgc_mat) <- colnames(ssgc_mat) <- names(rwl) + rownames(overlap_n) <- colnames(overlap_n) <- names(rwl) + treering_sign <- apply(rwl, 2, diff) treering_sign <- sign(treering_sign) for (i in 1:n) { treering_GC <- abs(treering_sign[,i]-treering_sign) diff --git a/man/chron.Rd b/man/chron.Rd index d847e61..0e2018c 100644 --- a/man/chron.Rd +++ b/man/chron.Rd @@ -8,13 +8,13 @@ \code{\link{detrend}}. } \usage{ -chron(x, biweight = TRUE, prewhiten = FALSE, \dots) +chron(rwi, biweight = TRUE, prewhiten = FALSE, \dots) } \arguments{ - \item{x}{a \code{data.frame} of (usually detrended) ring widths with - \code{rownames(\var{x})} containing years and \code{colnames(x)} + \item{rwi}{a \code{data.frame} of (usually detrended) ring widths with + \code{rownames(\var{rwi})} containing years and \code{colnames(rwi)} containing each series \acronym{ID} such as produced by - \code{\link{read.rwl}}} + \code{\link{detrend}}} \item{biweight}{\code{logical} flag. If \acronym{TRUE} then a robust mean is calculated using \code{\link{tbrm}.}} \item{prewhiten}{\code{logical} flag. If \acronym{TRUE} each series is diff --git a/man/chron.ars.Rd b/man/chron.ars.Rd index bf4f3a2..9017418 100644 --- a/man/chron.ars.Rd +++ b/man/chron.ars.Rd @@ -9,14 +9,14 @@ \code{\link{detrend}}. } \usage{ -chron.ars(x, biweight=TRUE, maxLag=10, firstAICmin=TRUE, +chron.ars(rwi, biweight=TRUE, maxLag=10, firstAICmin=TRUE, verbose=TRUE, prewhitenMethod=c("ar.yw","arima.CSS-ML")) } \arguments{ - \item{x}{a \code{data.frame} of (usually detrended) ring widths with - \code{rownames(\var{x})} containing years and \code{colnames(x)} + \item{rwi}{a \code{data.frame} of (usually detrended) ring widths with + \code{rownames(\var{rwi})} containing years and \code{colnames(rwi)} containing each series \acronym{ID} such as produced by - \code{\link{read.rwl}}} + \code{\link{detrend}}} \item{biweight}{\code{logical} flag. If \acronym{TRUE} then a robust mean is calculated using \code{\link{tbrm}.}} \item{maxLag}{an \code{integer} giving the maximum lag to consider in @@ -98,7 +98,7 @@ chron.ars(x, biweight=TRUE, maxLag=10, firstAICmin=TRUE, \item{samp.depth}{the number of series with non-missing values in each year.} - Row names are the years taken from \code{rownames(x)}. + Row names are the years taken from \code{rownames(rwi)}. } \references{ Cook, E. R. and Kairiukstis, L. A., editors (1990) \emph{Methods of diff --git a/man/sgc.Rd b/man/sgc.Rd index 8838282..044856b 100644 --- a/man/sgc.Rd +++ b/man/sgc.Rd @@ -10,11 +10,11 @@ } \usage{ - sgc(x,overlap = 50, prob = TRUE) + sgc(rwl, overlap = 50, prob = TRUE) } \arguments{ - \item{x}{ a \code{data.frame} of tree-ring data with records in columns, and years as rows. } + \item{rwl}{ an \code{rwl} object such as that produced by \code{\link{read.rwl}}. Also accepts a \code{data.frame} with series in columns and years as row names. } \item{overlap}{ integer value with minimal length of overlapping growth changes (compared number of tree rings - 1). Comparisons with less overlap are not compared.} \item{prob}{if \code{TRUE} then the probability of exceedence of the sgc will be calculated} } @@ -36,7 +36,7 @@ } The matrices can be extracted from the list by selecting the name or the index number. Comparisons are only compared if the overlap is above the set theshold and if no threshold is set, this defaults to 50 years.If no comparison can be compared, \code{NA} is returned. - To calculate the global sgc of the dataset (assuming \code{x.sgc <- sgc(x)}: \code{mean(x.sgc$sgc_mat, na.rm = TRUE))}. For the global ssgc use: \code{mean(x.sgc$ssgc_mat, na.rm = TRUE)}. + To calculate the global sgc of the dataset (assuming \code{x.sgc <- sgc(rwl)}: \code{mean(x.sgc$sgc_mat, na.rm = TRUE))}. For the global ssgc use: \code{mean(x.sgc$ssgc_mat, na.rm = TRUE)}. } diff --git a/tests/testthat/test-check.rwl.R b/tests/testthat/test-check.rwl.R new file mode 100644 index 0000000..850c0e4 --- /dev/null +++ b/tests/testthat/test-check.rwl.R @@ -0,0 +1,165 @@ +context("check.rwl and as.rwl") + +test.check.rwl <- function() { + + ## ------------------------------------------------------------------ ## + ## Shared test objects ## + ## ------------------------------------------------------------------ ## + + ## Minimal rwl: three series, leading/trailing NAs only, no internal NAs + good.rwl <- data.frame( + A = c(1.0, 1.2, 1.1, 0.9, NA), + B = c(NA, 0.9, 1.0, 1.1, 1.0), + C = c(NA, NA, 0.8, 0.9, 1.0) + ) + row.names(good.rwl) <- as.character(1901:1905) + class(good.rwl) <- c("rwl", "data.frame") + + ## Same data as a plain data.frame (no rwl class) + good.df <- good.rwl + class(good.df) <- "data.frame" + + ## Non-consecutive years (1904 missing) + bad.years <- good.df + row.names(bad.years) <- as.character(c(1901:1903, 1905:1906)) + + ## Non-numeric column + bad.cols <- data.frame(A = letters[1:5], stringsAsFactors = FALSE) + row.names(bad.cols) <- as.character(1901:1905) + + ## Non-data.frame input + bad.class <- list(A = 1:5) + + ## rwl with a genuine internal NA in series A + ## A: 1.0, 1.2, NA, 0.9, NA → NA at row 3 is internal (rows 1-4 span) + internal.na.rwl <- good.rwl + internal.na.rwl[3, "A"] <- NA + + ## ------------------------------------------------------------------ ## + ## check.rwl: happy path ## + ## ------------------------------------------------------------------ ## + + test_that("check.rwl is silent on a proper rwl", { + expect_silent(check.rwl(good.rwl)) + }) + + test_that("check.rwl returns the input unchanged for a proper rwl", { + result <- check.rwl(good.rwl) + expect_identical(result, good.rwl) + }) + + ## ------------------------------------------------------------------ ## + ## check.rwl: coercion path (valid structure, wrong class) ## + ## ------------------------------------------------------------------ ## + + test_that("check.rwl warns and coerces a plain data.frame", { + expect_warning(check.rwl(good.df), "Coerced successfully") + }) + + test_that("check.rwl returns rwl class after successful coercion", { + result <- suppressWarnings(check.rwl(good.df)) + expect_s3_class(result, "rwl") + }) + + ## ------------------------------------------------------------------ ## + ## check.rwl: failure path (structural problems) ## + ## ------------------------------------------------------------------ ## + + test_that("check.rwl stops with combined message on non-consecutive years", { + expect_error(check.rwl(bad.years), + regexp = "coercion failed.*consecutive integers", + perl = TRUE) + }) + + test_that("check.rwl stops with combined message on non-numeric columns", { + expect_error(check.rwl(bad.cols), + regexp = "coercion failed.*numeric columns", + perl = TRUE) + }) + + test_that("check.rwl stops with combined message on non-data.frame input", { + expect_error(check.rwl(bad.class), + regexp = "coercion failed.*data.frame or matrix", + perl = TRUE) + }) + + test_that("check.rwl error mentions class problem, not internal function", { + msg <- tryCatch(check.rwl(bad.years), error = conditionMessage) + expect_match(msg, "not class") + expect_false(grepl("as\\.rwl", msg)) + }) + + ## ------------------------------------------------------------------ ## + ## check.rwl: internal NA warning ## + ## ------------------------------------------------------------------ ## + + test_that("check.rwl warns about internal NAs and names the series", { + expect_warning(check.rwl(internal.na.rwl), + regexp = "Internal NA.*\\bA\\b", + perl = TRUE) + }) + + test_that("check.rwl internal NA warning mentions fill.internal.NA", { + w <- tryCatch( + withCallingHandlers(check.rwl(internal.na.rwl), + warning = function(w) { + if (grepl("Internal NA", conditionMessage(w))) { + invokeRestart("muffleWarning") + } + }), + warning = conditionMessage + ) + ## The warning object is muffled above; capture it another way + msgs <- character(0) + withCallingHandlers(check.rwl(internal.na.rwl), + warning = function(w) { + msgs <<- c(msgs, conditionMessage(w)) + invokeRestart("muffleWarning") + }) + internal.msg <- msgs[grepl("Internal NA", msgs)] + expect_true(length(internal.msg) > 0) + expect_match(internal.msg, "fill.internal.NA") + }) + + test_that("check.rwl does not warn about series with only trailing NAs", { + ## Series A trailing NA (row 5) is NOT internal — should be no warning + expect_silent(check.rwl(good.rwl)) + }) + + ## ------------------------------------------------------------------ ## + ## as.rwl ## + ## ------------------------------------------------------------------ ## + + test_that("as.rwl assigns rwl class to a plain data.frame", { + result <- as.rwl(good.df) + expect_s3_class(result, "rwl") + }) + + test_that("as.rwl is idempotent on an rwl object", { + result <- as.rwl(good.rwl) + expect_identical(result, good.rwl) + }) + + test_that("as.rwl converts a numeric matrix to rwl", { + mat <- matrix(c(1.0, 1.2, 1.1, + NA, 0.9, 1.0), + nrow = 3, + dimnames = list(as.character(1901:1903), c("A", "B"))) + result <- as.rwl(mat) + expect_s3_class(result, "rwl") + expect_true(is.data.frame(result)) + }) + + test_that("as.rwl stops on non-numeric columns", { + expect_error(as.rwl(bad.cols), "'x' must have numeric columns") + }) + + test_that("as.rwl stops on non-consecutive year row names", { + expect_error(as.rwl(bad.years), "consecutive integers") + }) + + test_that("as.rwl stops on non-data.frame/matrix input", { + expect_error(as.rwl(bad.class), "data.frame or matrix") + }) +} +test.check.rwl()