[Dplr-commits] r939 - in pkg/dplR: . inst tests tests/testthat
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Jan 14 17:19:57 CET 2015
Author: mvkorpel
Date: 2015-01-14 17:19:57 +0100 (Wed, 14 Jan 2015)
New Revision: 939
Added:
pkg/dplR/tests/testthat.R
pkg/dplR/tests/testthat/
pkg/dplR/tests/testthat/test-chron.R
pkg/dplR/tests/testthat/test-dplR.R
pkg/dplR/tests/testthat/test-io.R
pkg/dplR/tests/testthat/test-utils.R
Removed:
pkg/dplR/inst/unitTests/
pkg/dplR/tests/doRUnit.R
Modified:
pkg/dplR/ChangeLog
pkg/dplR/DESCRIPTION
Log:
Unit tests are now done with "testthat" instead of "RUnit" (which is
now ORPHANED on CRAN). Almost minimal changes were made to the test
files to make them fit the requirements of "testthat". There are also
other small optimizations and at least one bug fix (hopefully not too
many new bugs). Some more changes to the test files would probably be
needed to properly follow the philosophy / intended usage pattern of
the new testing package (which still seems to be changing as new
versions are released).
Modified: pkg/dplR/ChangeLog
===================================================================
--- pkg/dplR/ChangeLog 2015-01-14 14:29:46 UTC (rev 938)
+++ pkg/dplR/ChangeLog 2015-01-14 16:19:57 UTC (rev 939)
@@ -6,6 +6,9 @@
- A new field, MailingList, shows the address of the web interface
to the dplR-help mailing list hosted on Google Groups.
- New Imported package: R.utils.
+- New Suggested package: testthat. Unit tests are now done with testthat
+ instead of RUnit.
+- RUnit is no longer Suggested.
File: NAMESPACE
---------------
Modified: pkg/dplR/DESCRIPTION
===================================================================
--- pkg/dplR/DESCRIPTION 2015-01-14 14:29:46 UTC (rev 938)
+++ pkg/dplR/DESCRIPTION 2015-01-14 16:19:57 UTC (rev 939)
@@ -3,7 +3,7 @@
Type: Package
Title: Dendrochronology Program Library in R
Version: 1.6.3
-Date: 2015-01-08
+Date: 2015-01-14
Authors at R: c(person("Andy", "Bunn", role = c("aut", "cph",
"cre", "trl"), email = "andy.bunn at wwu.edu"), person("Mikko",
"Korpela", role = c("aut", "trl")), person("Franco", "Biondi",
@@ -22,7 +22,7 @@
digest (>= 0.2.3), gmp (>= 0.5-2), png (>= 0.1-1), R.utils (>=
1.32.0), stringi (>= 0.2-2), stringr (>= 0.4), XML (>= 2.1-0)
Suggests: Biobase, dichromat (>= 1.2-3), foreach, forecast, iterators,
- knitr, RColorBrewer, RUnit (>= 0.4.25), tikzDevice, waveslim
+ knitr, RColorBrewer, testthat (>= 0.8), tikzDevice, waveslim
Description: This package contains functions for performing tree-ring
analyses such as detrending, chronology building, and cross dating.
The package reads and writes standard file formats used in
Deleted: pkg/dplR/tests/doRUnit.R
===================================================================
--- pkg/dplR/tests/doRUnit.R 2015-01-14 14:29:46 UTC (rev 938)
+++ pkg/dplR/tests/doRUnit.R 2015-01-14 16:19:57 UTC (rev 939)
@@ -1,57 +0,0 @@
-## File adapted from R Wiki
-
-## Unit tests will not be done if RUnit is not available.
-## The warning in R Wiki code is omitted here.
-if(require(package="RUnit", quietly=TRUE)) {
-
- ## --- Setup ---
-
- pkg <- "dplR"
- if(Sys.getenv("RCMDCHECK") == "FALSE") {
- ## Path to unit tests for standalone running under Makefile
- ## (not R CMD check)
- ## PKG/tests/../inst/unitTests
- path <- file.path(getwd(), "..", "inst", "unitTests")
- } else {
- ## Path to unit tests for R CMD check
- ## PKG.Rcheck/tests/../PKG/unitTests
- path <- system.file(package=pkg, "unitTests")
- }
- cat("\nRunning unit tests\n")
- print(list(pkg=pkg, getwd=getwd(), pathToUnitTests=path))
-
- library(package=pkg, character.only=TRUE)
-
- ## --- Testing ---
-
- ## Define tests
- testSuite <- defineTestSuite(name=paste(pkg, "unit testing"),
- dirs=path)
- ## Run
- tests <- runTestSuite(testSuite)
-
- ## Default report name
- pathReport <- file.path(path, "report")
-
- ## Report to stdout and text files
- cat("------------------- UNIT TEST SUMMARY ---------------------\n\n")
- printTextProtocol(tests, showDetails=FALSE)
- printTextProtocol(tests, showDetails=FALSE,
- fileName=paste(pathReport, "Summary.txt", sep=""))
- printTextProtocol(tests, showDetails=TRUE,
- fileName=paste(pathReport, ".txt", sep=""))
-
- ## Report to HTML file
- printHTMLProtocol(tests, fileName=paste(pathReport, ".html", sep=""))
-
- ## Return stop() to cause R CMD check stop in case of
- ## - failures i.e. FALSE to unit tests or
- ## - errors i.e. R errors
- tmp <- getErrors(tests)
- if(tmp$nFail > 0 || tmp$nErr > 0) {
- stop(paste("\n\nunit testing failed (#test failures: ", tmp$nFail,
- ", #R errors: ", tmp$nErr, ")\n\n", sep=""))
- }
-} else {
- warning("cannot run unit tests -- package RUnit is not available")
-}
Added: pkg/dplR/tests/testthat/test-chron.R
===================================================================
--- pkg/dplR/tests/testthat/test-chron.R (rev 0)
+++ pkg/dplR/tests/testthat/test-chron.R 2015-01-14 16:19:57 UTC (rev 939)
@@ -0,0 +1,45 @@
+context("function chron")
+test.chron <- function() {
+ ## RNG Setup for srs1 (we use a _particular_ random series...)
+ if (!exists(".Random.seed", 1)) {
+ if (getRversion() <= "3.0.0") {
+ runif(1)
+ } else {
+ set.seed(NULL)
+ }
+ }
+ seed <- get(".Random.seed", 1)
+ on.exit(assign(".Random.seed", seed, 1))
+ RNGversion("2.15.0")
+ set.seed(0)
+
+ ## Other setup
+ N <- 500
+ srs1 <- pmax(rnorm(N, 1, 0.4), 0.1)
+ dat1 <- data.frame(srs1 - 0.05, srs1, srs1 + 0.05)
+ res1.1 <- chron(dat1, prefix = "xxx", biweight = FALSE, prewhiten = TRUE)
+ res1.2 <- chron(dat1, prefix = "xxx", biweight = TRUE, prewhiten = FALSE)
+
+ srs2 <- 0.5 * sin(pi / 50 * seq_len(N)) + 1 # period is 100
+ sd2.1 <- sd(srs2)
+ dat2 <- data.frame(srs2 - 0.1, srs2, srs2 + 0.1)
+ res2 <- chron(dat2, prefix = "xxx", biweight = FALSE, prewhiten = TRUE)
+ sd2.2 <- sd(res2[["xxxres"]], na.rm=TRUE)
+ threes <- rep.int(3, N)
+
+ ## Test
+ test_that("chron works (no autocorrelation)", {
+ expect_equal(res1.1[["samp.depth"]], threes)
+ expect_equal(res1.2[["samp.depth"]], threes)
+ expect_equal(res1.1[["xxxstd"]], srs1)
+ expect_equal(res1.2[["xxxstd"]], srs1)
+ expect_equal(res1.1[["xxxres"]], srs1)
+ })
+ test_that("chron works (with autocorrelation)", {
+ expect_equal(res2[["samp.depth"]], threes)
+ expect_equal(res2[["xxxstd"]], srs2)
+ expect_more_than(length(which(is.na(res2[["xxxres"]]))), 0)
+ expect_less_than(sd2.2, sd2.1)
+ })
+}
+test.chron()
Property changes on: pkg/dplR/tests/testthat/test-chron.R
___________________________________________________________________
Added: svn:eol-style
+ native
Added: pkg/dplR/tests/testthat/test-dplR.R
===================================================================
--- pkg/dplR/tests/testthat/test-dplR.R (rev 0)
+++ pkg/dplR/tests/testthat/test-dplR.R 2015-01-14 16:19:57 UTC (rev 939)
@@ -0,0 +1,705 @@
+context("multiple core functions of dplR")
+test.bai.in <- function() {
+ ## Test
+ base.seq <- pi * seq(from=3, by=2, length.out=19)
+ ones <- rep.int(1, 20)
+ test_that("bai.in works with zero d2pith", {
+ expect_equal(c(pi, base.seq), bai.in(data.frame(ones))[[1]])
+ })
+ test_that("bai.in works with nonzero d2pith", {
+ expect_equal(c(base.seq, 41 * pi),
+ bai.in(data.frame(x1 = ones),
+ d2pith = data.frame(series="x1", d2pith=1))[[1]])
+ })
+}
+test.bai.in()
+test.bai.out <- function() {
+ ## Test
+ base.seq <- pi * seq(from=3, by=2, length.out=19)
+ ones <- rep.int(1, 20)
+ test_that("bai.out works with zero diam", {
+ expect_equal(c(pi, base.seq), bai.out(data.frame(ones))[[1]])
+ })
+ test_that("bai.in works with nonzero diam", {
+ expect_equal(c(base.seq, 41 * pi),
+ bai.out(data.frame(x1 = ones),
+ diam = data.frame(series="x1", diam=42))[[1]])
+ })
+}
+test.bai.out()
+test.ccf.series.rwl <- function() {
+ ## Setup
+ srs1 <- seq(from=1, to=2, length.out=500)
+ names(srs1) <- seq_along(srs1)
+ dat1 <- data.frame(srs1, srs1 + 0.05, srs1 + 0.1)
+ ## perfect correlation at lag 0 (mean of dat1 is srs1 + constant)
+ res1.1 <- ccf.series.rwl(rwl = dat1, series = srs1,
+ seg.length = 100, bin.floor = 100,
+ prewhiten = FALSE, biweight = TRUE,
+ make.plot = FALSE, floor.plus1 = FALSE)
+ res1.2 <- ccf.series.rwl(rwl = dat1, series = srs1,
+ seg.length = 100, bin.floor = 100,
+ prewhiten = FALSE, biweight = FALSE,
+ make.plot = FALSE, floor.plus1 = TRUE)
+ res1.3 <- ccf.series.rwl(rwl = dat1, series = srs1,
+ seg.length = 100, bin.floor = 100,
+ prewhiten = TRUE, biweight = FALSE,
+ make.plot = FALSE, floor.plus1 = TRUE)
+ bins1.1 <- res1.1[["bins"]]
+ bins1.2 <- res1.2[["bins"]]
+ bins1.3 <- res1.3[["bins"]]
+ nrow1.3 <- nrow(bins1.3)
+ rnames1 <- rownames(res1.2[["ccf"]])
+
+ srs2 <- sin(pi / 4 * seq_len(500)) + 1.5 # period is 8
+ names(srs2) <- seq_along(srs2)
+ dat2 <- data.frame(srs2)
+ ## perfect correlation at lag 0 (the single column dat2 is a copy of srs2)
+ res2 <- ccf.series.rwl(rwl = dat2, series = srs2,
+ seg.length = 250, bin.floor = 100,
+ prewhiten = FALSE, lag.max = 7,
+ make.plot = FALSE, floor.plus1 = TRUE)
+ ccf2 <- res2[["ccf"]]
+ bins2 <- res2[["bins"]]
+ rnames2 <- rownames(ccf2)
+
+ ## Test
+ test_that("ccf.series.rwl bins are correct", {
+ expect_equal(nrow(bins1.1), 7)
+ expect_equal(nrow(bins1.2), 9)
+ expect_equal(bins1.1[1, 1], 100)
+ expect_equal(bins1.2[1, 1], 1)
+ expect_equal(bins1.1[7, 2], 499)
+ expect_equal(bins1.2[9, 2], 500)
+ expect_equal(bins1.3[nrow1.3, 2], 500)
+ expect_equal(nrow(bins2), 3)
+ expect_equal(bins2[, 1], c(1, 126, 251))
+ expect_equal(bins2[, 2], c(250, 375, 500))
+ })
+ test_that("lag 0 cor is 1 when series differ by a constant", {
+ expect_equivalent(res1.1[["ccf"]]["lag.0", ], rep.int(1, 7))
+ expect_equivalent(res1.2[["ccf"]]["lag.0", ], rep.int(1, 9))
+ expect_equivalent(res1.3[["ccf"]]["lag.0", ], rep.int(1, nrow1.3))
+ })
+ test_that("ccf.series.rwl responds to lag.max", {
+ expect_equal(length(rnames1), 11, info="default lag.max = 5")
+ expect_equal(length(rnames2), 15)
+ })
+ test_that("lagged correlations with a sinusoid are correct", {
+ expect_true(all(rnames2[apply(abs(ccf2), 2, which.min)] %in%
+ c("lag.-6", "lag.-2", "lag.2", "lag.6")),
+ info="phase difference of 1/4 or 3/4 cycles")
+ expect_true(all(rnames2[apply(ccf2, 2, which.min)] %in%
+ c("lag.-4", "lag.4")),
+ info="phase difference of 1/2 cycles")
+ expect_true(all(rnames2[apply(ccf2, 2, which.max)] == "lag.0"),
+ info="same phase")
+ })
+}
+test.ccf.series.rwl()
+test.combine.rwl <- function() {
+ ## Setup
+ v.1 <- 1 + runif(300)
+ range.1 <- 51:400
+ rnames.1 <- as.character(range.1)
+ range.2 <- range.1 + 150
+ rnames.2 <- as.character(range.2)
+ range.3 <- range.1 + 350
+ rnames.3 <- as.character(range.3)
+ range.4 <- range.1 + 450
+ rnames.4 <- as.character(range.4)
+ df.1 <- data.frame(col1 = c(v.1, rep.int(NA, 50)),
+ col2 = c(rep.int(NA, 25), v.1, rep.int(NA, 25)),
+ col3 = c(rep.int(NA, 50), v.1),
+ row.names = rnames.1)
+ df.2 <- df.1
+ rownames(df.2) <- rnames.2
+ df.3 <- df.1
+ rownames(df.3) <- rnames.3
+ df.4 <- df.1
+ rownames(df.4) <- rnames.4
+ res.3 <- combine.rwl(list(df.1))
+ res.4 <- combine.rwl(list(df.1, df.2, df.3, df.4))
+ res.5 <- combine.rwl(df.1, df.1)
+ res.6 <- combine.rwl(df.1, df.2)
+ res.7 <- combine.rwl(df.1, df.3)
+ res.8 <- combine.rwl(df.1, df.4)
+ ## Test
+ test_that("combine.rwl stops with nothing to combine", {
+ expect_error(combine.rwl(list()))
+ expect_error(combine.rwl(df.1))
+ })
+ test_that("combine.rwl works with a list of length one", {
+ expect_equal(res.3, df.1)
+ })
+ test_that("combine.rwl works with multiple data.frames", {
+ expect_equal(ncol(res.4), 12)
+ expect_equal(res.4[1:350, 1:3], df.1)
+ expect_equal(res.4[150+(1:350), 4:6], df.2)
+ expect_equal(res.4[350+(1:350), 7:9], df.3)
+ expect_equal(res.4[450+(1:350), 10:12], df.4)
+ })
+ test_that("combine.rwl works with identical data.frames", {
+ ## ... but names will be duplicated (names are not tested)
+ expect_equal(ncol(res.5), 6)
+ expect_equal(res.5[1:3], df.1)
+ expect_equal(res.5[4:6], df.1)
+ })
+ ## 6. ...have partially overlapping years
+ test_that("combine.rwl works with partially overlapping years", {
+ expect_equal(ncol(res.6), 6)
+ expect_equal(nrow(res.6), 500)
+ expect_equal(res.6[1:350, 1:3], df.1)
+ expect_equal(res.6[150+(1:350), 4:6], df.2)
+ })
+ ## 7. ...have separate sets of years so that the result is continuous
+ ## (y starts where x ends)
+ test_that("combine.rwl works with separate, continuous, years", {
+ expect_equal(ncol(res.7), 6)
+ expect_equal(nrow(res.7), 700)
+ expect_equal(res.7[1:350, 1:3], df.1)
+ expect_equal(res.7[350+(1:350), 4:6], df.3)
+ })
+ ## 8. ...have separate sets of years so that the result is discontinuous
+ test_that("combine.rwl works with separate, discontinuous, years", {
+ expect_equal(ncol(res.8), 6)
+ expect_equal(nrow(res.8), 800)
+ expect_equal(res.8[1:350, 1:3], df.1)
+ expect_equal(res.8[450+(1:350), 4:6], df.4)
+ })
+}
+test.combine.rwl()
+test.corr.rwl.seg <- function() {
+ ## Setup
+ srs1 <- rep.int(seq(from=0.5, to=1.5, length.out=50), 10)
+ srs2 <- rev(srs1)
+ srs3 <- srs1
+ srs3[26:75] <- rev(srs3[26:75])
+ srs4 <- srs1
+ srs4[126:175] <- rev(srs4[126:175])
+ srs4[326:425] <- rev(srs4[326:425])
+ names(srs1) <- seq_along(srs1)
+ dat1 <- data.frame(a=srs1, b=srs1, c=srs1, d=srs1, e=srs1, f=srs1, g=srs1)
+ dat2 <- dat1
+ dat2[1] <- srs2
+ dat3 <- dat1
+ dat3[1] <- srs3
+ dat3[2] <- srs4
+ res1 <- corr.rwl.seg(dat1, seg.length=50, bin.floor=100, make.plot=FALSE)
+ res2 <- corr.rwl.seg(dat2, seg.length=50, bin.floor=100, make.plot=FALSE)
+ res3 <- corr.rwl.seg(dat3, seg.length=100, bin.floor=100, pcrit=0.05,
+ make.plot=FALSE)
+ res4 <- corr.rwl.seg(dat3, seg.length=100, bin.floor=100, pcrit=0.05,
+ prewhiten=FALSE, floor.plus1=TRUE, make.plot=FALSE)
+ expected.cnames1 <- paste(res1[["bins"]][, 1], res1[["bins"]][, 2], sep=".")
+ expected.cnames3 <- paste(res3[["bins"]][, 1], res3[["bins"]][, 2], sep=".")
+ expected.cnames4 <- paste(res4[["bins"]][, 1], res4[["bins"]][, 2], sep=".")
+ expected.rnames <- c("a", "b", "c", "d", "e", "f", "g")
+ expected.corr1 <- array(1, dim(res1[["spearman.rho"]]),
+ dimnames=list(expected.rnames, expected.cnames1))
+ expected.corr2 <- expected.corr1
+ expected.corr2[1, ] <- -1
+ expected.overall1 <- array(data=c(rep.int(1, 7), rep.int(0, 7)),
+ dim=c(7,2), dimnames=list(expected.rnames,
+ c("rho", "p-val")))
+ expected.overall2 <- expected.overall1
+ expected.overall2["a", "rho"] <- -1
+ expected.overall2["a", "p-val"] <- 1
+ seg.names1 <- paste(seq(from=100, to=450, by=25),
+ seq(from=149, to=499, by=25), sep=".")
+ expected.avg1 <- rep.int(1, length(seg.names1))
+ names(expected.avg1) <- seg.names1
+ expected.avg2 <- rep.int(5/7, length(seg.names1))
+ names(expected.avg2) <- seg.names1
+ expected.flags1 <- array(0, dim(res1[["p.val"]]),
+ dimnames=list(expected.rnames, expected.cnames1))
+ expected.flags2 <- expected.flags1
+ expected.flags3 <- array(0, dim(res3[["p.val"]]),
+ dimnames=list(expected.rnames, expected.cnames3))
+ expected.flags4 <- array(0, dim(res4[["p.val"]]),
+ dimnames=list(expected.rnames, expected.cnames4))
+ expected.flags2[1, ] <- 1
+ expected.flags3[2, c("100.199", "300.399", "350.449")] <- 1
+ expected.flags4[1, "1.100"] <- 1
+ expected.flags4[2, c("101.200", "301.400", "351.450")] <- 1
+ res1.flags <- array(0, dim(res1[["p.val"]]),
+ dimnames=dimnames(res1[["p.val"]]))
+ res1.flags[res1[["p.val"]] >= 0.05] <- 1
+ res2.flags <- array(0, dim(res2[["p.val"]]),
+ dimnames=dimnames(res2[["p.val"]]))
+ res2.flags[res2[["p.val"]] >= 0.05] <- 1
+ res3.flags <- array(0, dim(res3[["p.val"]]),
+ dimnames=dimnames(res3[["p.val"]]))
+ res3.flags[res3[["p.val"]] >= 0.05] <- 1
+ res4.flags <- array(0, dim(res4[["p.val"]]),
+ dimnames=dimnames(res4[["p.val"]]))
+ res4.flags[res4[["p.val"]] >= 0.05] <- 1
+
+ ## Test
+ test_that("corr.rwl.seg bins are correct", {
+ expect_true(all(res1[["bins"]][, 2] - res1[["bins"]][, 1] + 1 == 50))
+ expect_equal(res1[["bins"]][1, 1], 100)
+ expect_true(all(diff(res1[["bins"]][, 1]) == 25))
+ expect_equal(res1[["bins"]][nrow(res1[["bins"]]), 1], 450)
+ expect_equal(res2[["bins"]], res1[["bins"]])
+ expect_true(all(res3[["bins"]][, 2] - res3[["bins"]][, 1] + 1 == 100))
+ expect_equal(res3[["bins"]][1, 1], 100)
+ expect_true(all(diff(res3[["bins"]][, 1]) == 50))
+ expect_equal(res3[["bins"]][nrow(res3[["bins"]]), 1], 400)
+ expect_true(all(res4[["bins"]][, 2] - res4[["bins"]][, 1] + 1 == 100))
+ expect_equal(res4[["bins"]][1, 1], 1)
+ expect_true(all(diff(res4[["bins"]][, 1]) == 50))
+ expect_equal(res4[["bins"]][nrow(res4[["bins"]]), 1], 401)
+ })
+ test_that("corr.rwl.seg correlations (by bin) are correct", {
+ expect_equal(res1[["spearman.rho"]], expected.corr1)
+ expect_equal(res2[["spearman.rho"]], expected.corr2)
+ })
+ test_that("corr.rwl.seg correlations (overall) are correct", {
+ expect_equal(res1[["overall"]], expected.overall1)
+ expect_equal(res2[["overall"]], expected.overall2)
+ })
+ test_that("corr.rwl.seg correlations (average) are correct", {
+ expect_equal(res1[["avg.seg.rho"]], expected.avg1)
+ expect_equal(res2[["avg.seg.rho"]], expected.avg2)
+ })
+ test_that("corr.rwl.seg P-values are correct", {
+ expect_equal(res1.flags, expected.flags1)
+ expect_equal(res2.flags, expected.flags2)
+ expect_equal(res3.flags, expected.flags3)
+ expect_equal(res4.flags, expected.flags4)
+ })
+ test_that("corr.rwl.seg flags are correct", {
+ expect_equal(length(res1[["flags"]]), 0)
+ expect_equal(length(res2[["flags"]]), 1)
+ expect_equal(length(res3[["flags"]]), 1)
+ expect_equal(length(res4[["flags"]]), 2)
+ expect_equal(res2[["flags"]][["a"]],
+ paste(seg.names1, collapse=", "))
+ expect_equal(res3[["flags"]][["b"]], "100.199, 300.399, 350.449")
+ expect_equal(res4[["flags"]][["a"]], "1.100")
+ expect_equal(res4[["flags"]][["b"]], "101.200, 301.400, 351.450")
+ })
+}
+test.corr.rwl.seg()
+test.corr.series.seg <- function() {
+ ## Setup
+ srs1 <- rep.int(seq(from=0.5, to=1.5, length.out=50), 10)
+ srs2 <- rev(srs1)
+ srs3 <- srs1
+ srs3[26:75] <- rev(srs3[26:75])
+ srs3[326:425] <- rev(srs3[326:425])
+ srs4 <- rep.int(seq(1, 2, length.out=50) + sin((1:50)*0.4), 10)
+ names(srs1) <- seq_along(srs1)
+ names(srs2) <- seq_along(srs2)
+ names(srs3) <- seq_along(srs3)
+ names(srs4) <- seq_along(srs4)
+ dat <- data.frame(a=srs1, b=srs1, c=srs1, d=srs1, e=srs1, f=srs1, g=srs1)
+ res1 <- corr.series.seg(rwl=dat, series=srs1, seg.length=50,
+ bin.floor=100, make.plot=FALSE)
+ res2 <- corr.series.seg(rwl=dat, series=srs2, seg.length=50,
+ bin.floor=100, make.plot=FALSE)
+ res3 <- corr.series.seg(rwl=dat, series=srs3, seg.length=100,
+ bin.floor=100, make.plot=FALSE)
+ res4 <- corr.series.seg(rwl=dat, series=srs3, seg.length=100,
+ prewhiten=FALSE, bin.floor=100,
+ make.plot=FALSE, floor.plus1=TRUE)
+ res5 <- corr.series.seg(rwl=dat, series=srs4, seg.length=50,
+ biweight=FALSE, prewhiten=FALSE,
+ bin.floor=100, make.plot=FALSE)
+ res6 <- corr.series.seg(rwl=dat, series=srs4, seg.length=50,
+ biweight=FALSE, prewhiten=FALSE,
+ bin.floor=100, make.plot=FALSE, method="spearman")
+ res6.2 <- corr.series.seg(rwl=dat, series=srs4, seg.length=50,
+ biweight=FALSE, prewhiten=FALSE,
+ bin.floor=50, make.plot=FALSE, method="spearman")
+ res7 <- corr.series.seg(rwl=dat, series=srs4, seg.length=50,
+ biweight=FALSE, prewhiten=FALSE,
+ bin.floor=100, make.plot=FALSE, method="pearson")
+ res8 <- corr.series.seg(rwl=dat, series=srs4, seg.length=50,
+ biweight=FALSE, prewhiten=FALSE,
+ bin.floor=100, make.plot=FALSE, method="kendall")
+ res9 <- corr.series.seg(rwl=dat, series=srs4, seg.length=48,
+ biweight=FALSE, prewhiten=FALSE,
+ bin.floor=100, make.plot=FALSE, method="pearson")
+ res10 <- corr.series.seg(rwl=dat, series=srs4, seg.length=100,
+ biweight=FALSE, prewhiten=FALSE,
+ bin.floor=100, make.plot=FALSE, method="pearson")
+ res11 <- corr.series.seg(rwl=dat, series=srs4, seg.length=142,
+ biweight=FALSE, prewhiten=FALSE,
+ bin.floor=100, make.plot=FALSE, method="pearson")
+
+ expected.cnames1 <- paste(res1[["bins"]][, 1], res1[["bins"]][, 2], sep=".")
+ expected.cnames3 <- paste(res3[["bins"]][, 1], res3[["bins"]][, 2], sep=".")
+ expected.cnames4 <- paste(res4[["bins"]][, 1], res4[["bins"]][, 2], sep=".")
+ expected.corr1 <- rep.int(1, length(res1[["spearman.rho"]]))
+ names(expected.corr1) <- expected.cnames1
+ expected.corr2 <- rep.int(-1, length(res2[["spearman.rho"]]))
+ names(expected.corr2) <- expected.cnames1
+ expected.overall1 <- c(1, 0)
+ names(expected.overall1) <- c("rho", "p-val")
+ expected.overall2 <- c(-1, 1)
+ names(expected.overall2) <- c("rho", "p-val")
+ expected.flags1 <- rep.int(0, length(res1[["p.val"]]))
+ names(expected.flags1) <- names(res1[["p.val"]])
+ expected.flags2 <- rep.int(1, length(res2[["p.val"]]))
+ names(expected.flags2) <- names(res2[["p.val"]])
+ expected.flags3 <- rep.int(0, length(res3[["p.val"]]))
+ names(expected.flags3) <- names(res3[["p.val"]])
+ expected.flags4 <- rep.int(0, length(res4[["p.val"]]))
+ names(expected.flags4) <- names(res4[["p.val"]])
+ expected.flags3[c("300.399", "350.449")] <- 1
+ expected.flags4[c("1.100", "301.400", "351.450")] <- 1
+ res1.flags <- rep.int(0, length(res1[["p.val"]]))
+ names(res1.flags) <- names(res1[["p.val"]])
+ res1.flags[res1[["p.val"]] >= 0.05] <- 1
+ res2.flags <- rep.int(0, length(res2[["p.val"]]))
+ names(res2.flags) <- names(res2[["p.val"]])
+ res2.flags[res2[["p.val"]] >= 0.05] <- 1
+ res3.flags <- rep.int(0, length(res3[["p.val"]]))
+ names(res3.flags) <- names(res3[["p.val"]])
+ res3.flags[res3[["p.val"]] >= 0.05] <- 1
+ res4.flags <- rep.int(0, length(res4[["p.val"]]))
+ names(res4.flags) <- names(res4[["p.val"]])
+ res4.flags[res4[["p.val"]] >= 0.05] <- 1
+ range.moving.3 <- range(res3[["moving.rho"]][, "rho"], na.rm=TRUE)
+ range.3 <- range(res3[["spearman.rho"]])
+
+ ## Test
+ test_that("corr.series.seg bins are correct", {
+ expect_true(all(res1[["bins"]][, 2] - res1[["bins"]][, 1] + 1 == 50))
+ expect_equal(res1[["bins"]][1, 1], 100)
+ expect_true(all(diff(res1[["bins"]][, 1]) == 25))
+ expect_equal(res1[["bins"]][nrow(res1[["bins"]]), 1], 450)
+ expect_equal(res1[["bins"]], res2[["bins"]])
+ expect_true(all(res3[["bins"]][, 2] - res3[["bins"]][, 1] + 1 == 100))
+ expect_equal(res3[["bins"]][1, 1], 100)
+ expect_true(all(diff(res3[["bins"]][, 1]) == 50))
+ expect_equal(res3[["bins"]][nrow(res3[["bins"]]), 1], 400)
+ expect_true(all(res4[["bins"]][, 2] - res4[["bins"]][, 1] + 1 == 100))
+ expect_equal(res4[["bins"]][1, 1], 1)
+ expect_true(all(diff(res4[["bins"]][, 1]) == 50))
+ expect_equal(res4[["bins"]][nrow(res4[["bins"]]), 1], 401)
+ })
+ test_that("corr.series.seg correlations (by bin) are correct", {
+ expect_equal(res1[["spearman.rho"]], expected.corr1)
+ expect_equal(res2[["spearman.rho"]], expected.corr2)
+ })
+ test_that("corr.series.seg correlations (overall) are correct", {
+ expect_equal(res1[["overall"]], expected.overall1)
+ expect_equal(res2[["overall"]], expected.overall2)
+ })
+ test_that("corr.series.seg P-values are correct", {
+ expect_equal(res1.flags, expected.flags1)
+ expect_equal(res2.flags, expected.flags2)
+ expect_equal(res3.flags, expected.flags3)
+ expect_equal(res4.flags, expected.flags4)
+ })
+ test_that("corr.series.seg correlations (moving) are correct", {
+ expect_equal(range(res1[["moving.rho"]][, "rho"], na.rm=TRUE), c(1, 1))
+ expect_equal(range(res2[["moving.rho"]][, "rho"], na.rm=TRUE),c(-1,-1))
+ expect_equal(range.moving.3,
+ c(min(range.moving.3[1], range.3[1]),
+ max(range.moving.3[2], range.3[2])))
+ expect_equal(range(res4[["moving.rho"]][, "rho"], na.rm=TRUE),c(-1, 1))
+ })
+ test_that("default method is spearman", {
+ tmpNames <- names(res5)
+ expect_named(res6, tmpNames)
+ for (i in seq_along(res5)) {
+ expect_equal(res6[[i]], res5[[i]], info = tmpNames[i])
+ }
+ })
+ test_that("correlation methods differ", {
+ expect_false(isTRUE(all.equal(res6[["overall"]], res7[["overall"]])))
+ expect_false(isTRUE(all.equal(res6[["overall"]], res8[["overall"]])))
+ expect_false(isTRUE(all.equal(res7[["overall"]], res8[["overall"]])))
+ expect_false(isTRUE(all.equal(res6[["moving.rho"]],
+ res7[["moving.rho"]])))
+ expect_false(isTRUE(all.equal(res6[["moving.rho"]],
+ res8[["moving.rho"]])))
+ expect_false(isTRUE(all.equal(res7[["moving.rho"]],
+ res8[["moving.rho"]])))
+ expect_false(isTRUE(all.equal(res6[["spearman.rho"]],
+ res7[["spearman.rho"]])))
+ expect_false(isTRUE(all.equal(res6[["spearman.rho"]],
+ res8[["spearman.rho"]])))
+ expect_false(isTRUE(all.equal(res7[["spearman.rho"]],
+ res8[["spearman.rho"]])))
+ })
+ tmp7 <- as.vector(na.omit(res7[["moving.rho"]][, "rho"]))
+ test_that("correlations are ok when segment length matches common cycle", {
+ expect_equal(length(tmp7), 451)
+ expect_equal(tmp7, rep.int(mean(tmp7), 451))
+ })
+ tmp9 <- na.omit(res9[["moving.rho"]][, "rho"])
+ uniqueRho9 <- unique(tmp9)
+ test_that("correlations are ok with segments shorter than common cycle", {
+ expect_equal(length(tmp9), 453)
+ expect_equal(length(uniqueRho9), 50)
+ })
+ tmp10 <- as.vector(na.omit(res10[["moving.rho"]][, "rho"]))
+ test_that("correlations are ok when multiple cycles fit segment exactly", {
+ expect_equal(length(tmp10), 401)
+ expect_equal(tmp10, rep.int(mean(tmp10), 401))
+ })
+ tmp11 <- na.omit(res11[["moving.rho"]][, "rho"])
+ uniqueRho11 <- unique(tmp11)
+ test_that("correlations are ok with segments longer than common cycle", {
+ expect_equal(length(tmp11), 359)
+ expect_equal(length(uniqueRho11), 50)
+ })
+ test_that("bin.floor argument works", {
+ expect_equal(length(res6.2[["spearman.rho"]]),
+ length(res6[["spearman.rho"]])+2)
+ expect_equal(res6.2[["spearman.rho"]][-c(1, 2)],
+ res6[["spearman.rho"]])
+ })
+}
+test.corr.series.seg()
+test.ffcsaps <- function() {
+ ## Setup
+ n <- 100
+ x <- seq_len(n)
+ y <- x + 10 * sin(pi / 15 * x) + 5 * rnorm(n)
+ lm.y <- lm(y ~ x)
+ fitted.y <- fitted(lm.y)
+ res.1 <- ffcsaps(y, f=0, nyrs=30)
+ res.2 <- ffcsaps(y, f=0.9, nyrs=30)
+ res.3 <- ffcsaps(y, f=0.9, nyrs=5)
+ res.4 <- ffcsaps(y, f=1, nyrs=30)
+ res.5 <- ffcsaps(x)
+ error.1 <- sum((y - res.1)^2)
+ error.2 <- sum((y - res.2)^2)
+ error.3 <- sum((y - res.3)^2)
+ ## Test
+ test_that("ffcsaps handles special cases", {
+ expect_equivalent(res.1, fitted.y)
+ expect_equal(res.4, y)
+ expect_equal(res.5, x)
+ })
+ test_that("smoother spline means more error", {
+ expect_more_than(error.1, error.2)
+ expect_more_than(error.2, error.3)
+ })
+ test_that("ffcsaps stops on bad parameters", {
+ expect_error(ffcsaps(y, f=-1))
+ expect_error(ffcsaps(y, f=2))
+ expect_error(ffcsaps(y, nyrs=0))
+ })
+}
+test.ffcsaps()
+test.gini.coef <- function() {
+ ## Setup
+ MAX.SIZE <- 1000
+ NTIMES <- 10
+ samp <- sample(seq.int(2, MAX.SIZE), max(0, min(NTIMES, MAX.SIZE - 1)))
+ ## Test
+ coefs <- vapply(samp,
+ function(x) {
+ foo <- numeric(x)
+ n <- sample(x - 1, 1)
+ nonzeros <- sample(x, n)
+ val <- runif(1, 1, 100)
+
+ foo[nonzeros[1]] <- val
+ a <- gini.coef(foo)
+
+ foo[nonzeros] <- val
+ b <- gini.coef(foo)
+
+ foo[] <- val
+ c <- gini.coef(foo)
+
+ c(a, b, c, n)
+ }, numeric(4))
+ test_that("gini.coef handles special cases", {
+ expect_equal(coefs[1, ], 1 - 1 / samp)
+ expect_equal(coefs[2, ], 1 - coefs[4, ] / samp)
+ expect_equal(coefs[3, ], numeric(length(samp)))
+ })
+}
+test.gini.coef()
+test.glk <- function() {
+ ## Setup
+ seq.inc <- seq_len(10)
+ seq.dec <- seq.int(from = -1, to = -10)
+ seq.rand <- sample(x = seq.inc, size = 10, replace = FALSE)
+ seq.step <- rep(seq.rand, each = 2)
+ seq.step <- seq.step[-length(seq.step)]
+ glk.4col <- glk(data.frame(seq.rand, seq.rand, seq.rand, seq.rand))
+ ## Test
+ test_that("result of glk is correctly formatted", {
+ expect_equal(nrow(glk.4col), 4)
+ expect_equal(ncol(glk.4col), 4)
+ expect_true(all(glk.4col[upper.tri(x = glk.4col, diag = FALSE)] == 1))
+ expect_true(all(is.na(glk.4col[lower.tri(x = glk.4col, diag = TRUE)])))
+ })
+ test_that("cases without simultaneous zero diffs are ok", {
+ expect_equal(glk(data.frame(seq.inc, seq.inc + 1))[1, 2], 1,
+ info="strictly monotonic sequences (both increasing)")
+ expect_equal(glk(data.frame(seq.inc, seq.dec))[1, 2], 0,
+ info="strictly monotonic sequences (incr., decr.)")
+ expect_equal(glk(data.frame(seq.rand, seq.rand + 1))[1, 2], 1,
+ info="signs of differences are the same")
+ expect_equal(glk(data.frame(seq.rand, -seq.rand))[1, 2], 0,
+ info="signs of differences are opposite")
+ expect_equal(glk(data.frame(seq.rand,
+ rep.int(1, length(seq.rand))))[1, 2],
+ 0.5, info="one sequence is constant")
+ })
+ test_that("dplR >= 1.6.1: zero diffs are in full agreement", {
+ expect_equal(glk(data.frame(seq.step, -seq.step))[1, 2], 0.5,
+ info="a zero difference in both series is full agreement")
+ expect_equal(glk(data.frame(seq.step, seq.step))[1, 2], 1,
+ info="glk() is 1 when comparing any sequence with itself")
+ expect_equal(glk(data.frame(seq.step,
+ rep.int(1, length(seq.step))))[1, 2],
+ 0.75, info="halfway between 0.5 and 1")
+ })
+}
+test.glk()
+test.hanning <- function() {
+ ## Setup
+ SAMP.SIZE <- 101
+ FILTER.LENGTH <- c(7, 51)
+ HALF.SIZE <- 50
+ x.constant <- rep.int(42, SAMP.SIZE)
+ x.impulse <- c(rep.int(0, HALF.SIZE), 1, rep.int(0, HALF.SIZE))
+ for (filter.length in FILTER.LENGTH) {
+ length.str <- paste0("filter length ", filter.length)
+ not.na.length <- SAMP.SIZE - filter.length + 1
+ y.constant <- hanning(x.constant, n=filter.length)
+ y.impulse <- hanning(x.impulse, n=filter.length)
+ not.na.constant <- which(!is.na(y.constant))
+ ## Test
+ test_that("number of NA values is correct", {
+ expect_equal(length(not.na.constant), not.na.length,
+ info=length.str)
+ })
+ test_that("a constant series stays constant", {
+ expect_equal(y.constant[not.na.constant],
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/dplr -r 939
More information about the Dplr-commits
mailing list