From noreply at r-forge.r-project.org Thu Jan 1 18:11:59 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 1 Jan 2015 18:11:59 +0100 (CET) Subject: [Dplr-commits] r931 - in pkg/dplR: . inst/unitTests Message-ID: <20150101171159.E6605187023@r-forge.r-project.org> Author: mvkorpel Date: 2015-01-01 18:11:59 +0100 (Thu, 01 Jan 2015) New Revision: 931 Modified: pkg/dplR/ChangeLog pkg/dplR/DESCRIPTION pkg/dplR/inst/unitTests/runit.dplR.R Log: Edited ChangeLog, changed unit tests to avoid identicality checks Modified: pkg/dplR/ChangeLog =================================================================== --- pkg/dplR/ChangeLog 2014-12-31 08:35:50 UTC (rev 930) +++ pkg/dplR/ChangeLog 2015-01-01 17:11:59 UTC (rev 931) @@ -1,3 +1,10 @@ +* CHANGES IN dplR VERSION 1.6.2 + +No functional changes. A unit test was changed so it would not fail +on the solaris-sparc CRAN platform. Also in some other tests, +identicality checks were replaced with near equality checks. + + * CHANGES IN dplR VERSION 1.6.1 @@ -3,13 +10,13 @@ File: glk.R and glk.Rd ------------- -- Modified by Christian Zang in reponse to a bug report by Allan Buras. In the - case of no change from year i to year i+1 in both series then the glk sign - will for both be 0 and the sum of both is then also 0 and will not be +- Modified by Christian Zang in response to a bug report by Allan Buras. In the + case of no change from year i to year i+1 in both series then the glk sign + will for both be 0 and the sum of both is then also 0 and will not be accounted for correctly in the sum of synchronous years. Zang and Buras have - pached and Zang updates the help file to reflect the change as: - "This implementation improves the original formulation inasmuch as the case - of neighbouring identical measurements in the same years is accounted for. - Here, it is treated as full agreement, in contrast to only partial agreement - in the original formulation."" + patched and Zang updated the help file to reflect the change as: + "This implementation improves the original formulation inasmuch as the case + of neighbouring identical measurements in the same years is accounted for. + Here, it is treated as full agreement, in contrast to only partial agreement + in the original formulation." File: crn.plot.R Modified: pkg/dplR/DESCRIPTION =================================================================== --- pkg/dplR/DESCRIPTION 2014-12-31 08:35:50 UTC (rev 930) +++ pkg/dplR/DESCRIPTION 2015-01-01 17:11:59 UTC (rev 931) @@ -3,7 +3,7 @@ Type: Package Title: Dendrochronology Program Library in R Version: 1.6.2 -Date: 2014-12-31 +Date: 2015-01-01 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", Modified: pkg/dplR/inst/unitTests/runit.dplR.R =================================================================== --- pkg/dplR/inst/unitTests/runit.dplR.R 2014-12-31 08:35:50 UTC (rev 930) +++ pkg/dplR/inst/unitTests/runit.dplR.R 2015-01-01 17:11:59 UTC (rev 931) @@ -405,8 +405,8 @@ checkTrue(res1$bins[nrow(res1$bins), 1] == 450, msg="Last bin is in correct position (test 1)") - checkIdentical(res1$bins, res2$bins, - msg="Bins are identical (tests 1 and 2)") + checkEquals(res1$bins, res2$bins, + msg="Bins are the same (tests 1 and 2)") checkTrue(all(res3$bins[, 2] - res3$bins[, 1] + 1 == 100), msg="Bins have correct length(test 3)") @@ -456,7 +456,14 @@ checkEquals(c(-1, 1), range(res4$moving.rho[, "rho"], na.rm=TRUE), msg="Moving correlations are as expected (test 4)") - checkIdentical(res5, res6, msg="Default method is spearman") + tmpNames <- names(res5) + checkEquals(tmpNames, names(res6), + msg="Result lists have the same names in the same order") + for (i in seq_along(res5)) { + checkEquals(res5[[i]], res6[[i]], + msg=sprintf("Default method is spearman (%s)", + tmpNames[i])) + } checkTrue(!isTRUE(all.equal(res6$overall, res7$overall)), msg="Overall correlation differs between methods (test 1)") checkTrue(!isTRUE(all.equal(res6$overall, res8$overall)), @@ -501,8 +508,8 @@ checkTrue(length(res6.2$spearman.rho) == length(res6$spearman.rho) + 2, msg = "Extra segments with different bin.floor") - checkIdentical(res6.2$spearman.rho[-c(1, 2)], res6$spearman.rho, - msg = "Other segments have identical correlation") + checkEquals(res6.2$spearman.rho[-c(1, 2)], res6$spearman.rho, + msg = "Other segments have the same correlation") } test.ffcsaps <- function() { From noreply at r-forge.r-project.org Sat Jan 3 08:46:21 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 3 Jan 2015 08:46:21 +0100 (CET) Subject: [Dplr-commits] r932 - in tags: . dplR-1.6.1 Message-ID: <20150103074621.C79D7184EAB@r-forge.r-project.org> Author: mvkorpel Date: 2015-01-03 08:46:21 +0100 (Sat, 03 Jan 2015) New Revision: 932 Added: tags/dplR-1.6.1/ Log: dplR 1.6.1 Property changes on: tags/dplR-1.6.1 ___________________________________________________________________ Added: svn:ignore + dplR-Ex.R svn*.tmp .* *~ .Rproj.user *.Rproj Added: svn:auto-props + *.c = svn:eol-style=LF *.h = svn:eol-style=LF Makefile = svn:eol-style=LF *.po = svn:eol-style=native *.pot = svn:eol-style=native *.R = svn:eol-style=native *.Rd = svn:eol-style=native *.Rnw = svn:eol-style=native *.sty = svn:eol-style=native Added: svn:mergeinfo + /branches/dplR-R-2.15:466-506 /branches/redfit:662-700 From noreply at r-forge.r-project.org Mon Jan 5 10:37:55 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 5 Jan 2015 10:37:55 +0100 (CET) Subject: [Dplr-commits] r933 - in tags: . dplR-1.6.2 Message-ID: <20150105093756.0BA291876B8@r-forge.r-project.org> Author: mvkorpel Date: 2015-01-05 10:37:55 +0100 (Mon, 05 Jan 2015) New Revision: 933 Added: tags/dplR-1.6.2/ Log: dplR 1.6.2 Property changes on: tags/dplR-1.6.2 ___________________________________________________________________ Added: svn:ignore + dplR-Ex.R svn*.tmp .* *~ .Rproj.user *.Rproj Added: svn:auto-props + *.c = svn:eol-style=LF *.h = svn:eol-style=LF Makefile = svn:eol-style=LF *.po = svn:eol-style=native *.pot = svn:eol-style=native *.R = svn:eol-style=native *.Rd = svn:eol-style=native *.Rnw = svn:eol-style=native *.sty = svn:eol-style=native Added: svn:mergeinfo + /branches/dplR-R-2.15:466-506 /branches/redfit:662-700 From noreply at r-forge.r-project.org Mon Jan 5 18:18:55 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 5 Jan 2015 18:18:55 +0100 (CET) Subject: [Dplr-commits] r934 - pkg/dplR Message-ID: <20150105171855.4AD10186BFF@r-forge.r-project.org> Author: mvkorpel Date: 2015-01-05 18:18:55 +0100 (Mon, 05 Jan 2015) New Revision: 934 Modified: pkg/dplR/ChangeLog pkg/dplR/DESCRIPTION Log: * First commit for future release 1.6.3 * Added address of mailing list (Google Group) to DESCRIPTION Modified: pkg/dplR/ChangeLog =================================================================== --- pkg/dplR/ChangeLog 2015-01-05 09:37:55 UTC (rev 933) +++ pkg/dplR/ChangeLog 2015-01-05 17:18:55 UTC (rev 934) @@ -1,3 +1,11 @@ +* CHANGES IN dplR VERSION 1.6.3 + +File: DESCRIPTION +----------------- + +- A new field, MailingList, shows the address of the web interface + to the dplR-help mailing list hosted on Google Groups + * CHANGES IN dplR VERSION 1.6.2 No functional changes. A unit test was changed so it would not fail Modified: pkg/dplR/DESCRIPTION =================================================================== --- pkg/dplR/DESCRIPTION 2015-01-05 09:37:55 UTC (rev 933) +++ pkg/dplR/DESCRIPTION 2015-01-05 17:18:55 UTC (rev 934) @@ -2,8 +2,8 @@ Package: dplR Type: Package Title: Dendrochronology Program Library in R -Version: 1.6.2 -Date: 2015-01-01 +Version: 1.6.3 +Date: 2015-01-05 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", @@ -31,3 +31,4 @@ License: GPL (>= 2) URL: http://huxley.wwu.edu/trl/htrl-dplr, http://R-Forge.R-project.org/projects/dplr/ +MailingList: https://groups.google.com/d/forum/dplr-help From noreply at r-forge.r-project.org Wed Jan 7 15:51:08 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 7 Jan 2015 15:51:08 +0100 (CET) Subject: [Dplr-commits] r935 - in pkg/dplR: . R man Message-ID: <20150107145108.831A71877B3@r-forge.r-project.org> Author: mvkorpel Date: 2015-01-07 15:51:08 +0100 (Wed, 07 Jan 2015) New Revision: 935 Modified: pkg/dplR/ChangeLog pkg/dplR/DESCRIPTION pkg/dplR/NAMESPACE pkg/dplR/R/latexify.R pkg/dplR/man/latexify.Rd Log: * In latexify.R, using captureOutput() from R.utils (a new import) improves efficiency of latexify() with certain large inputs. The previous solution to the handling of "bytes" was a home-baked one re-implementing parts of capture.output(), a function which I wasn't aware of until now. * In DESCRIPTION, the order of packages in Imports was changed: "base" packages first, followed by "recommended" packages, then others. Modified: pkg/dplR/ChangeLog =================================================================== --- pkg/dplR/ChangeLog 2015-01-05 17:18:55 UTC (rev 934) +++ pkg/dplR/ChangeLog 2015-01-07 14:51:08 UTC (rev 935) @@ -4,8 +4,25 @@ ----------------- - A new field, MailingList, shows the address of the web interface - to the dplR-help mailing list hosted on Google Groups + to the dplR-help mailing list hosted on Google Groups. +- New Imported package: R.utils. +File: NAMESPACE +--------------- + +- Import captureOutput from R.utils. + +File: latexify.R +---------------- + +- Improved efficiency when handling a large number of strings with + the "bytes" Encoding. The code now uses R.utils::captureOutput() + instead of a home-baked re-implementation of (parts of) + utils::capture.output(), which is also a more compact solution in + terms of lines of code in dplR. See Henrik Bengtsson's notes at + http://www.jottr.org/2014/05/captureOutput.html (referenced on + 2015-01-07). + * CHANGES IN dplR VERSION 1.6.2 No functional changes. A unit test was changed so it would not fail Modified: pkg/dplR/DESCRIPTION =================================================================== --- pkg/dplR/DESCRIPTION 2015-01-05 17:18:55 UTC (rev 934) +++ pkg/dplR/DESCRIPTION 2015-01-07 14:51:08 UTC (rev 935) @@ -3,7 +3,7 @@ Type: Package Title: Dendrochronology Program Library in R Version: 1.6.3 -Date: 2015-01-05 +Date: 2015-01-07 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", @@ -18,9 +18,9 @@ Copyright: Authors and Aalto University (for work of M. Korpela) Maintainer: Andy Bunn Depends: R (>= 2.15.0) -Imports: gmp (>= 0.5-2), graphics, grDevices, grid, stats, utils, - digest (>= 0.2.3), lattice (>= 0.13-6), png (>= 0.1-1), - stringi (>= 0.2-2), stringr (>= 0.4), XML (>= 2.1-0) +Imports: graphics, grDevices, grid, stats, utils, lattice (>= 0.13-6), + 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 Description: This package contains functions for performing tree-ring Modified: pkg/dplR/NAMESPACE =================================================================== --- pkg/dplR/NAMESPACE 2015-01-05 17:18:55 UTC (rev 934) +++ pkg/dplR/NAMESPACE 2015-01-07 14:51:08 UTC (rev 935) @@ -22,6 +22,8 @@ importFrom(png, readPNG) +importFrom(R.utils, captureOutput) + importFrom(stringi, stri_trans_nfc, stri_trans_nfd) importFrom(stringr, str_pad, str_trim) Modified: pkg/dplR/R/latexify.R =================================================================== --- pkg/dplR/R/latexify.R 2015-01-05 17:18:55 UTC (rev 934) +++ pkg/dplR/R/latexify.R 2015-01-07 14:51:08 UTC (rev 935) @@ -23,15 +23,7 @@ ## in a way which preserves the hex notation. encBytes <- Encoding(y) == "bytes" if (any(encBytes)) { - foo <- character(0) # dummy line - tc <- textConnection("foo", "w", local = TRUE) - sink(tc) - on.exit(sink()) - on.exit(close(tc), add = TRUE) - ## Embedded newlines (if any) in y[encBytes] will not cause - ## line breaks with cat(). - cat(y[encBytes], sep = "\n") - y[encBytes] <- foo + y[encBytes] <- captureOutput(cat(y[encBytes], sep = "\n")) } l10n <- l10n_info() Letters <- paste0(c(LETTERS, letters), collapse="") Modified: pkg/dplR/man/latexify.Rd =================================================================== --- pkg/dplR/man/latexify.Rd 2015-01-05 17:18:55 UTC (rev 934) +++ pkg/dplR/man/latexify.Rd 2015-01-07 14:51:08 UTC (rev 935) @@ -63,7 +63,7 @@ Before applying the substitutions described above, input elements with \code{\link{Encoding}} set to \code{"bytes"} are printed and the - result is captured using the current text encoding. The result of + output is stored using \code{\link{captureOutput}}. The result of this intermediate stage is \acronym{ASCII} text where some characters are shown as their byte codes using a hexadecimal pair prefixed with \code{"\\x"}. This set includes tabs, newlines and control From noreply at r-forge.r-project.org Thu Jan 8 14:22:04 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 8 Jan 2015 14:22:04 +0100 (CET) Subject: [Dplr-commits] r936 - in pkg/dplR: . inst/unitTests Message-ID: <20150108132204.EF5971875A7@r-forge.r-project.org> Author: mvkorpel Date: 2015-01-08 14:22:04 +0100 (Thu, 08 Jan 2015) New Revision: 936 Modified: pkg/dplR/DESCRIPTION pkg/dplR/inst/unitTests/runit.utils.R Log: Improved unit test of latexify(): * The "latin1" string was slightly modified * A test case for the "bytes" encoding, using a copy of the "latin1" string * Use capture.output() instead of a home-grown solution for recording how R prints strings Modified: pkg/dplR/DESCRIPTION =================================================================== --- pkg/dplR/DESCRIPTION 2015-01-07 14:51:08 UTC (rev 935) +++ pkg/dplR/DESCRIPTION 2015-01-08 13:22:04 UTC (rev 936) @@ -3,7 +3,7 @@ Type: Package Title: Dendrochronology Program Library in R Version: 1.6.3 -Date: 2015-01-07 +Date: 2015-01-08 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", Modified: pkg/dplR/inst/unitTests/runit.utils.R =================================================================== --- pkg/dplR/inst/unitTests/runit.utils.R 2015-01-07 14:51:08 UTC (rev 935) +++ pkg/dplR/inst/unitTests/runit.utils.R 2015-01-08 13:22:04 UTC (rev 936) @@ -207,9 +207,27 @@ tolerance=0) checkTrue(all(specialChars %in% specialMap[, 1]), msg="Each special character has a mapping") + ## A test for handling of different encodings in the input - latin1String <- "clich\xe9 ma\xf1ana" + + ## The following string must have a literal (escaped) backspace + ## and "x" in front of every "special" character (byte), and each + ## character code must consist of two hexadecimal digits. + bytePrint <- "clich\\xe9\\x0ama\\xf1ana" # "\x0a" is a newline + + codeLoc <- as.vector(gregexpr("\\x", bytePrint, fixed=TRUE)[[1]]) + asSuch <- substring(bytePrint, + c(1, codeLoc + 4), + c(codeLoc - 1, nchar(bytePrint))) + special <- + rawToChar(as.raw(paste0("0x", substring(bytePrint, + codeLoc + 2, codeLoc + 3))), + multiple = TRUE) + latin1String <- paste0(asSuch, c(special, ""), collapse="") Encoding(latin1String) <- "latin1" + byteString <- latin1String + Encoding(byteString) <- "bytes" + latinConverted <- latexify(latin1String, doublebackslash=FALSE) checkEquals("clich\\'{e} ma\\~{n}ana", latinConverted, @@ -217,6 +235,11 @@ checkEquals(latinConverted, latexify(enc2utf8(latin1String), doublebackslash=FALSE), msg="Encoding of the input does not matter") + byteConverted <- latexify(byteString, doublebackslash=FALSE) + checkEquals(gsub("\\", "\\textbackslash ", bytePrint, fixed=TRUE), + tolower(byteConverted),# do hex codes print in lower case? + msg="Conversion of byte string succeeded") + ## A test for other than default quoting options quoteString <- "\"It's five o'clock\", he said." res1 <- latexify(quoteString, doublebackslash=FALSE) @@ -330,9 +353,10 @@ "\\usepackage[T1]{fontenc}", "\\usepackage{lmodern}", "}}") - id <- c(testStrings, latin1String, rep(quoteString, 5), nestQuotes, - diaeresisD, diaeresisC, allChars) - extraInfo <- c(rep("", length(testStrings) + length(latin1String)), + id <- c(testStrings, latin1String, byteString, rep(quoteString, 5), + nestQuotes, diaeresisD, diaeresisC, allChars) + extraInfo <- c(rep("", length(testStrings) + length(latin1String) + + length(byteString)), paste0(" (", c("default", "curved", "no packages", "only fontenc", "only textcomp"), ")"), rep("", length(nestQuotes)), @@ -341,20 +365,10 @@ rep("", length(allChars))) ## Record how R prints the elements in 'id' - inputDescription <- character(length(id)) # dummy line - tc <- textConnection("inputDescription", "w", local = TRUE) - sink(tc) - on.exit(sink()) - on.exit(close(tc), add = TRUE) - for (i in seq_along(id)) { - print(id[i]) - } - sink() - close(tc) - on.exit() + inputDescription <- capture.output(invisible(vapply(id, print, ""))) - allOutput <- c(ltxSingle, latinConverted, res1, res2, res3, res4, - res5, nq, diasD, diasC, ac) + allOutput <- c(ltxSingle, latinConverted, byteConverted, res1, res2, + res3, res4, res5, nq, diasD, diasC, ac) if (is.character(con)) { co <- file(con, open = "wt", encoding = "UTF-8") on.exit(close(co)) From noreply at r-forge.r-project.org Mon Jan 12 10:09:50 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 12 Jan 2015 10:09:50 +0100 (CET) Subject: [Dplr-commits] r937 - pkg/dplR/man Message-ID: <20150112090950.D087C1812CB@r-forge.r-project.org> Author: mvkorpel Date: 2015-01-12 10:09:50 +0100 (Mon, 12 Jan 2015) New Revision: 937 Modified: pkg/dplR/man/rwi.stats.running.Rd Log: Formatting: added spaces between initials and a period Modified: pkg/dplR/man/rwi.stats.running.Rd =================================================================== --- pkg/dplR/man/rwi.stats.running.Rd 2015-01-08 13:22:04 UTC (rev 936) +++ pkg/dplR/man/rwi.stats.running.Rd 2015-01-12 09:09:50 UTC (rev 937) @@ -202,8 +202,8 @@ Springer. \acronym{ISBN-13}: 978-0-7923-0586-6. Cook, E. R. and Pederson, N. (2011) \emph{Uncertainty, Emergence, and - Statistics in Dendrochronology} In M.K. Hughes, T.W. Swetnam, and - H.F. Diaz (Eds.), \emph{Dendroclimatology} (77\enc{?}{--}112), + Statistics in Dendrochronology}. In M. K. Hughes, T. W. Swetnam, and + H. F. Diaz (Eds.), \emph{Dendroclimatology} (77\enc{?}{--}112), \acronym{ISBN-13}: 978-1-4020-4010-8. Fritts, H. C. (2001) \emph{Tree Rings and Climate}. Blackburn. From noreply at r-forge.r-project.org Wed Jan 14 15:29:47 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 14 Jan 2015 15:29:47 +0100 (CET) Subject: [Dplr-commits] r938 - in pkg/dplR: . R Message-ID: <20150114142947.551B7187943@r-forge.r-project.org> Author: mvkorpel Date: 2015-01-14 15:29:46 +0100 (Wed, 14 Jan 2015) New Revision: 938 Modified: pkg/dplR/ChangeLog pkg/dplR/R/ccf.series.rwl.R pkg/dplR/R/corr.rwl.seg.R pkg/dplR/R/corr.series.seg.R pkg/dplR/R/redfit.R pkg/dplR/R/series.rwl.plot.R Log: Using deparse.level=0 in some calls to cbind() and rbind(). Modified: pkg/dplR/ChangeLog =================================================================== --- pkg/dplR/ChangeLog 2015-01-12 09:09:50 UTC (rev 937) +++ pkg/dplR/ChangeLog 2015-01-14 14:29:46 UTC (rev 938) @@ -12,6 +12,15 @@ - Import captureOutput from R.utils. +Various .R files +---------------- + +- Using deparse.level=0 in some calls to cbind() and rbind() when names + are not needed in the result. Due to this change, the first column of + the $bins matrix in the return value of ccf.series.rwl(), + corr.rwl.seg(), and corr.series.seg() does not have (undocumented) + column names anymore. + File: latexify.R ---------------- Modified: pkg/dplR/R/ccf.series.rwl.R =================================================================== --- pkg/dplR/R/ccf.series.rwl.R 2015-01-12 09:09:50 UTC (rev 937) +++ pkg/dplR/R/ccf.series.rwl.R 2015-01-14 14:29:46 UTC (rev 938) @@ -58,7 +58,7 @@ stop("shorten 'seg.length' or adjust 'bin.floor'") } bins <- seq(from=min.bin, to=to + seg.lag, by=seg.lag) - bins <- cbind(bins, bins + (seg.length - 1)) + bins <- cbind(bins, bins + (seg.length - 1), deparse.level=0) nbins <- nrow(bins) bin.names <- paste0(bins[, 1], ".", bins[, 2]) Modified: pkg/dplR/R/corr.rwl.seg.R =================================================================== --- pkg/dplR/R/corr.rwl.seg.R 2015-01-12 09:09:50 UTC (rev 937) +++ pkg/dplR/R/corr.rwl.seg.R 2015-01-14 14:29:46 UTC (rev 938) @@ -128,7 +128,7 @@ stop("shorten 'seg.length' or adjust 'bin.floor'") } bins <- seq(from=min.bin, to=max.bin, by=seg.lag) - bins <- cbind(bins, bins + (seg.length - 1)) + bins <- cbind(bins, bins + (seg.length - 1), deparse.level=0) nbins <- nrow(bins) bin.names <- paste0(bins[, 1], ".", bins[, 2]) ## structures for results Modified: pkg/dplR/R/corr.series.seg.R =================================================================== --- pkg/dplR/R/corr.series.seg.R 2015-01-12 09:09:50 UTC (rev 937) +++ pkg/dplR/R/corr.series.seg.R 2015-01-14 14:29:46 UTC (rev 938) @@ -67,7 +67,7 @@ stop("shorten 'seg.length' or adjust 'bin.floor'") } bins <- seq(from=min.bin, to=to + seg.lag, by=seg.lag) - bins <- cbind(bins, bins + (seg.length - 1)) + bins <- cbind(bins, bins + (seg.length - 1), deparse.level=0) nbins <- nrow(bins) bin.names <- paste0(bins[, 1], ".", bins[, 2]) ## structures for results Modified: pkg/dplR/R/redfit.R =================================================================== --- pkg/dplR/R/redfit.R 2015-01-12 09:09:50 UTC (rev 937) +++ pkg/dplR/R/redfit.R 2015-01-14 14:29:46 UTC (rev 938) @@ -1134,11 +1134,11 @@ lowlow[lowGood] <- pnorm(rcritlo[lowGood] - 0.5, mean = nMean[lowGood], sd = nSd[lowGood]) lowhigh <- pnorm(rcritlo + 0.5, mean = nMean, sd = nSd) - list(rbind(rcritlo, rcrithi), + list(rbind(rcritlo, rcrithi, deparse.level=0), pmin = 2 * max(lowlow), pmax = 2 * min(lowhigh)) } else { - rbind(rcritlo, rcrithi) + rbind(rcritlo, rcrithi, deparse.level=0) } } Modified: pkg/dplR/R/series.rwl.plot.R =================================================================== --- pkg/dplR/R/series.rwl.plot.R 2015-01-12 09:09:50 UTC (rev 937) +++ pkg/dplR/R/series.rwl.plot.R 2015-01-14 14:29:46 UTC (rev 938) @@ -62,7 +62,7 @@ stop("shorten 'seg.length' or adjust 'bin.floor'") } bins <- seq(from=min.bin, to=to + seg.lag, by=seg.lag) - bins <- cbind(bins, bins + (seg.length - 1)) + bins <- cbind(bins, bins + (seg.length - 1), deparse.level=0) nbins <- nrow(bins) op <- par(no.readonly=TRUE) From noreply at r-forge.r-project.org Wed Jan 14 17:19:57 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 14 Jan 2015 17:19:57 +0100 (CET) Subject: [Dplr-commits] r939 - in pkg/dplR: . inst tests tests/testthat Message-ID: <20150114161957.D7A60187812@r-forge.r-project.org> 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 From noreply at r-forge.r-project.org Wed Jan 14 18:03:07 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 14 Jan 2015 18:03:07 +0100 (CET) Subject: [Dplr-commits] r940 - in pkg/dplR: . inst Message-ID: <20150114170307.8C148187752@r-forge.r-project.org> Author: mvkorpel Date: 2015-01-14 18:03:03 +0100 (Wed, 14 Jan 2015) New Revision: 940 Modified: pkg/dplR/ChangeLog pkg/dplR/inst/CITATION Log: Keeping R CMD check --as-cran (recent R-devel) happy by removing some obsolete code. Modified: pkg/dplR/ChangeLog =================================================================== --- pkg/dplR/ChangeLog 2015-01-14 16:19:57 UTC (rev 939) +++ pkg/dplR/ChangeLog 2015-01-14 17:03:03 UTC (rev 940) @@ -1,5 +1,11 @@ * CHANGES IN dplR VERSION 1.6.3 +File: CITATION +-------------- + +- Removed a piece of obsolete code which raised a NOTE in recent R-devel + when checking --as-cran. + File: DESCRIPTION ----------------- Modified: pkg/dplR/inst/CITATION =================================================================== --- pkg/dplR/inst/CITATION 2015-01-14 16:19:57 UTC (rev 939) +++ pkg/dplR/inst/CITATION 2015-01-14 17:03:03 UTC (rev 940) @@ -1,7 +1,3 @@ -if(!exists("meta") || is.null(meta)) { - meta <- packageDescription("dplR") -} - bibentry(bibtype = "Article", title = "A dendrochronology program library in R (dplR)", journal = "Dendrochronologia", From noreply at r-forge.r-project.org Thu Jan 15 09:29:01 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 15 Jan 2015 09:29:01 +0100 (CET) Subject: [Dplr-commits] r941 - pkg/dplR Message-ID: <20150115082901.ADDE1186870@r-forge.r-project.org> Author: mvkorpel Date: 2015-01-15 09:29:01 +0100 (Thu, 15 Jan 2015) New Revision: 941 Modified: pkg/dplR/ChangeLog pkg/dplR/DESCRIPTION Log: Updated the version requirement of gmp to >= 0.5-5 which actually works. Modified: pkg/dplR/ChangeLog =================================================================== --- pkg/dplR/ChangeLog 2015-01-14 17:03:03 UTC (rev 940) +++ pkg/dplR/ChangeLog 2015-01-15 08:29:01 UTC (rev 941) @@ -15,6 +15,9 @@ - New Suggested package: testthat. Unit tests are now done with testthat instead of RUnit. - RUnit is no longer Suggested. +- Updated version requirement: gmp (>= 0.5-5). Earlier versions of gmp do + not export is.bigq() which is required by dplR. The previous version + requirement (>= 0.5-2) was a mistake. File: NAMESPACE --------------- Modified: pkg/dplR/DESCRIPTION =================================================================== --- pkg/dplR/DESCRIPTION 2015-01-14 17:03:03 UTC (rev 940) +++ pkg/dplR/DESCRIPTION 2015-01-15 08:29:01 UTC (rev 941) @@ -3,7 +3,7 @@ Type: Package Title: Dendrochronology Program Library in R Version: 1.6.3 -Date: 2015-01-14 +Date: 2015-01-15 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", @@ -19,7 +19,7 @@ Maintainer: Andy Bunn Depends: R (>= 2.15.0) Imports: graphics, grDevices, grid, stats, utils, lattice (>= 0.13-6), - digest (>= 0.2.3), gmp (>= 0.5-2), png (>= 0.1-1), R.utils (>= + digest (>= 0.2.3), gmp (>= 0.5-5), 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, testthat (>= 0.8), tikzDevice, waveslim From noreply at r-forge.r-project.org Mon Jan 19 17:09:01 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 19 Jan 2015 17:09:01 +0100 (CET) Subject: [Dplr-commits] r942 - in pkg/dplR: . R man Message-ID: <20150119160901.126F8187661@r-forge.r-project.org> Author: mvkorpel Date: 2015-01-19 17:09:00 +0100 (Mon, 19 Jan 2015) New Revision: 942 Added: pkg/dplR/R/net.R pkg/dplR/man/net.Rd Modified: pkg/dplR/ChangeLog pkg/dplR/DESCRIPTION pkg/dplR/NAMESPACE pkg/dplR/R/helpers.R Log: NET (Esper et al.) Modified: pkg/dplR/ChangeLog =================================================================== --- pkg/dplR/ChangeLog 2015-01-15 08:29:01 UTC (rev 941) +++ pkg/dplR/ChangeLog 2015-01-19 16:09:00 UTC (rev 942) @@ -22,7 +22,8 @@ File: NAMESPACE --------------- -- Import captureOutput from R.utils. +- Importing captureOutput() from R.utils. +- Exporting net(). Various .R files ---------------- @@ -44,6 +45,11 @@ http://www.jottr.org/2014/05/captureOutput.html (referenced on 2015-01-07). +File: net.R +----------- + +- New function for computing the NET parameter (Esper et al., 2001). + * CHANGES IN dplR VERSION 1.6.2 No functional changes. A unit test was changed so it would not fail Modified: pkg/dplR/DESCRIPTION =================================================================== --- pkg/dplR/DESCRIPTION 2015-01-15 08:29:01 UTC (rev 941) +++ pkg/dplR/DESCRIPTION 2015-01-19 16:09:00 UTC (rev 942) @@ -3,7 +3,7 @@ Type: Package Title: Dendrochronology Program Library in R Version: 1.6.3 -Date: 2015-01-15 +Date: 2015-01-19 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", Modified: pkg/dplR/NAMESPACE =================================================================== --- pkg/dplR/NAMESPACE 2015-01-15 08:29:01 UTC (rev 941) +++ pkg/dplR/NAMESPACE 2015-01-19 16:09:00 UTC (rev 942) @@ -37,7 +37,7 @@ combine.rwl, common.interval, corr.rwl.seg, corr.series.seg, crn.plot, detrend, detrend.series, ffcsaps, fill.internal.NA, gini.coef, glk, hanning, i.detrend, i.detrend.series, morlet, - po.to.wc, pointer, powt, print.redfit, rcs, read.compact, + net, po.to.wc, pointer, powt, print.redfit, rcs, read.compact, read.crn, read.fh, read.ids, read.rwl, read.tridas, read.tucson, redfit, runcrit, rwi.stats, rwi.stats.legacy, rwi.stats.running, rwl.stats, sea, seg.plot, sens1, sens2, Modified: pkg/dplR/R/helpers.R =================================================================== --- pkg/dplR/R/helpers.R 2015-01-15 08:29:01 UTC (rev 941) +++ pkg/dplR/R/helpers.R 2015-01-19 16:09:00 UTC (rev 942) @@ -357,3 +357,37 @@ y <- ceiling(y) y } + +## Reorders vector x according to partial matching of its names to the +## names in Table. This is designed to replicate argument matching in +## R function calls, which also means that it is possible to omit some +## or all names in x. There is no equivalent of default values here, +## i.e. the lengths of the arguments must match. +vecMatched <- function(x, Table) { + stopifnot(is.character(Table), !is.na(Table), nzchar(Table), + length(x) == length(Table)) + xNames <- names(x) + y <- as.vector(x) + N <- length(Table) + if (!is.null(xNames)) { + matches <- pmatch(xNames, Table) + isNA <- is.na(matches) + nNA <- sum(isNA) + if (nNA == 0) { + y[matches] <- x + } else { + flagBad <- nzchar(xNames[isNA]) + if (any(flagBad)) { + stop(gettextf("unknown element(s): %s", + paste(xNames[isNA][flagBad],collapse=", "))) + } + if (nNA < N) { + notNA <- !isNA + theMatch <- matches[notNA] + y[theMatch] <- x[notNA] + y[seq_len(N)[-theMatch]] <- x[isNA] + } + } + } + y +} Added: pkg/dplR/R/net.R =================================================================== --- pkg/dplR/R/net.R (rev 0) +++ pkg/dplR/R/net.R 2015-01-19 16:09:00 UTC (rev 942) @@ -0,0 +1,34 @@ +net <- function(x, weights = c(v=1, g=1)) { + stopifnot(is.numeric(weights), is.finite(weights)) + weights2 <- vecMatched(weights, c("v", "g")) + dimX <- dim(x) + if (is.null(dimX) || length(dimX) != 2) { + stop("'x' must be a matrix-like object") + } + if (!isTRUE(all(dimX >= 2))) { + stop("'x' must have at least 2 rows and 2 columns") + } + x2 <- as.matrix(x) + if (!is.numeric(x2)) { + stop("'x' must contain numeric data") + } + ## Standard deviation standardized by mean + variability <- function(mat) { + Sd <- apply(mat, 1, sd, na.rm = TRUE) + Mean <- rowMeans(mat, na.rm = TRUE) + Sd / Mean + } + ## Gleichlaufigkeit as in the NET paper by Esper et al. + gleichlauf <- function(mat) { + delta <- diff(mat) + isNA <- is.na(delta) + N <- ncol(mat) - rowSums(isNA) + delta[isNA] <- 0 + pos <- rowSums(delta > 0) + neg <- rowSums(delta < 0) + c(NA_real_, pmax(pos, neg) / N) + } + NetJ <- weights2[1] * variability(x2) + weights2[2] * (1 - gleichlauf(x2)) + Net <- mean(NetJ, na.rm = TRUE) + list(all = NetJ, average = Net) +} Property changes on: pkg/dplR/R/net.R ___________________________________________________________________ Added: svn:eol-style + native Added: pkg/dplR/man/net.Rd =================================================================== --- pkg/dplR/man/net.Rd (rev 0) +++ pkg/dplR/man/net.Rd 2015-01-19 16:09:00 UTC (rev 942) @@ -0,0 +1,89 @@ +\name{net} +\alias{net} +\title{ + Calculate NET +} +\description{ + Computes the \eqn{\mathit{NET}}{NET} parameter for a set of tree-ring + records or other time-series data. +} +\usage{ +net(x, weights = c(v = 1, g = 1)) +} +\arguments{ + \item{x}{ + A \code{matrix} or \code{data.frame} with at least two rows and two + columns containing \code{numeric} data. The rows should represent a + sequence of sampling points with uniform intervals (e.g. a range of + years), but this is not checked. Each column is a time-series + spanning either the whole time range or a part of it. + } + \item{weights}{ + A \code{numeric} vector with two elements. Normally, variation + (\code{"v"}) and \enc{Gegenl?ufigkeit}{Gegenlaeufigkeit} + (\code{"g"}) contribute to NET with equal weight. It is possible to + use different weights by setting them here. The names of the vector + are matched to \code{c("v", "g")} (see \sQuote{Examples}). If no + names are given, the first element is the weight of variation. + } +} +\details{ + + This function computes the \eqn{\mathit{NET}}{NET} parameter (Esper et + al., 2001). The overall \eqn{\mathit{NET}}{NET} is an average of all + (non-\code{NA}) yearly values \eqn{\mathit{NET_j}}{NET[j]}, which are + computed as follows: + + \deqn{\mathit{NET_j}=v_j+(1-G_j)}{NET[j] = v[j] + (1-G[j])} + + The yearly variation \eqn{v_j}{v[j]} is the standard deviation of the + measurements of a single year divided by their mean. + \enc{Gegenl?ufigkeit}{Gegenlaeufigkeit} \eqn{1-G_j}{1-G[j]} is based + on one definition of \enc{Gleichl?ufigkeit}{Gleichlaeufigkeit} + \eqn{G_j}{G[j]}, similar to but not the same as what \code{\link{glk}} + computes. Particularly, in the formula used by this function (Esper + et al., 2001), simultaneous zero differences in two series are not + counted as a synchronous change. + + The weights of \eqn{v_j}{v[j]} and \eqn{1-G_j}{1-G[j]} in the sum can + be adjusted with the argument \code{\var{weights}} (see above). As a + rather extreme example, it is possible to isolate variation or + \enc{Gegenl?ufigkeit}{Gegenlaeufigkeit} by setting one of the weights + to zero (see \sQuote{Examples}). + +} +\value{ + + A \code{list} with the following components, in the same order as + described here: + + \item{all }{a \code{numeric} vector containing + \eqn{\mathit{NET_j}}{NET[j]}. Row names of \code{\var{x}} (if any) + are copied here. } + + \item{average }{a \code{numeric} value \eqn{\mathit{NET}}{NET}, the + average of the \code{"all"} vector (\code{NA} values removed). } + +} +\references{ + + Esper, J., Neuwirth, B., Treydte, K. (2001) A new parameter to + evaluate temporal signal strength of tree-ring chronologies. + \emph{Dendrochronologia}, 19(1):93\enc{?}{--}102. + +} +\author{ + Mikko Korpela +} +\examples{data(ca533) +ca533.rwi <- detrend(rwl = ca533, method = "ModNegExp") +ca533.net <- net(ca533.rwi) +tail(ca533.net$all) +ca533.net$average +\dontrun{ +## Isolate the components of NET +ca533.v <- net(ca533.rwi, weights=c(v=1,0)) +ca533.g <- net(ca533.rwi, weights=c(g=1,0)) +} +} +\keyword{ ts } Property changes on: pkg/dplR/man/net.Rd ___________________________________________________________________ Added: svn:eol-style + native From noreply at r-forge.r-project.org Tue Jan 20 18:14:31 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 20 Jan 2015 18:14:31 +0100 (CET) Subject: [Dplr-commits] r943 - in pkg/dplR: . tests/testthat Message-ID: <20150120171431.690F6183C43@r-forge.r-project.org> Author: mvkorpel Date: 2015-01-20 18:14:31 +0100 (Tue, 20 Jan 2015) New Revision: 943 Modified: pkg/dplR/DESCRIPTION pkg/dplR/tests/testthat/test-dplR.R Log: Tests for net() Modified: pkg/dplR/DESCRIPTION =================================================================== --- pkg/dplR/DESCRIPTION 2015-01-19 16:09:00 UTC (rev 942) +++ pkg/dplR/DESCRIPTION 2015-01-20 17:14:31 UTC (rev 943) @@ -3,7 +3,7 @@ Type: Package Title: Dendrochronology Program Library in R Version: 1.6.3 -Date: 2015-01-19 +Date: 2015-01-20 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", Modified: pkg/dplR/tests/testthat/test-dplR.R =================================================================== --- pkg/dplR/tests/testthat/test-dplR.R 2015-01-19 16:09:00 UTC (rev 942) +++ pkg/dplR/tests/testthat/test-dplR.R 2015-01-20 17:14:31 UTC (rev 943) @@ -591,6 +591,55 @@ }) } test.hanning() +test.net <- function() { + ## Setup + seq.inc <- seq_len(10) + seq.rand <- sample(x = seq.inc, size = 10, replace = FALSE) + rowNames <- as.character(seq(from=100, length.out=length(seq.inc))) + testFrame <- data.frame(seq.rand, seq.rand, seq.rand, seq.rand, + row.names = rowNames) + net.testFrame <- net(testFrame) + ## Test + test_that("result of net is correctly formatted", { + expect_is(net.testFrame, "list") + expect_named(net.testFrame, c("all", "average")) + expect_named(net.testFrame[["all"]], rowNames) + expect_equivalent(net.testFrame[["all"]], c(NA_real_, rep.int(0, 9))) + expect_equal(net.testFrame[["average"]], 0) + }) + test_that("net returns correct results", { + seq.dec <- seq.int(from = -1, to = -10) + testFrame2 <- data.frame(seq.inc, seq.inc, seq.inc, seq.dec) + exp1 <- c(NA_real_, rep.int(2.25, 9)) + exp2 <- c(NA_real_, rep.int(2, 9)) + exp3 <- c(NA_real_, rep.int(0.25, 9)) + expect_equal(net(testFrame2)[["all"]], exp1) + expect_equal(net(testFrame2, weights=c(v=1, 0))[["all"]], exp2) + expect_equal(net(testFrame2, weights=c(g=1, 0))[["all"]], exp3) + testFrame3 <- testFrame2[c(1:5, 5, 6:10), ] + row.names(testFrame3) <- NULL + expect_equal(net(testFrame3)[["all"]], c(exp1[1:5], 3, exp1[6:10])) + expect_equal(net(testFrame3, weights=c(v=1, 0))[["all"]], + c(exp2[1:5], 2, exp2[6:10])) + expect_equal(net(testFrame3, weights=c(g=1, 0))[["all"]], + c(exp3[1:5], 1, exp3[6:10])) + }) + test_that("input can be matrix or data.frame", { + net.matrix <- net(as.matrix(testFrame)) + expect_equal(net.matrix[["all"]], net.testFrame[["all"]]) + expect_equal(net.matrix[["average"]], net.testFrame[["average"]]) + }) + test_that("invalid input and parameters fail", { + expect_error(net(1:5), "matrix-like") + expect_error(net(as.matrix(1:5)), "2 columns") + expect_error(net(t(as.matrix(1:5))), "2 rows") + expect_error(net(testFrame, weights = c(dontexist = 1, 0)), "unknown") + expect_error(net(testFrame, weights = c(1, NA_real_)), "is.finite") + expect_error(net(testFrame, weights = c(1, 1, 1)), "length") + expect_error(net(testFrame, weights = c("a", "b")), "is.numeric") + }) +} +test.net() test.read.ids <- function() { ## Setup site <- "abc" From noreply at r-forge.r-project.org Tue Jan 20 19:09:11 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 20 Jan 2015 19:09:11 +0100 (CET) Subject: [Dplr-commits] r944 - in pkg/dplR: R tests/testthat Message-ID: <20150120180911.1C117183A10@r-forge.r-project.org> Author: mvkorpel Date: 2015-01-20 19:09:10 +0100 (Tue, 20 Jan 2015) New Revision: 944 Modified: pkg/dplR/R/net.R pkg/dplR/tests/testthat/test-dplR.R Log: In net(), if the user sets one of the weights to zero while the other weight is non-zero, possible NAs from the "zeroed" statistic should arguably not propagate to the result ("just give me variability" or "just give me Gegenlaufigkeit"). This commit addresses the issue by explicitly checking for zero weights and only computing what is needed. In the case of both weights being zero, the result is set to NA_real (average is NaN). Modified: pkg/dplR/R/net.R =================================================================== --- pkg/dplR/R/net.R 2015-01-20 17:14:31 UTC (rev 943) +++ pkg/dplR/R/net.R 2015-01-20 18:09:10 UTC (rev 944) @@ -26,9 +26,23 @@ delta[isNA] <- 0 pos <- rowSums(delta > 0) neg <- rowSums(delta < 0) - c(NA_real_, pmax(pos, neg) / N) + res <- c(NA_real_, pmax(pos, neg) / N) + names(res) <- rownames(mat) + res } - NetJ <- weights2[1] * variability(x2) + weights2[2] * (1 - gleichlauf(x2)) + w1 <- weights2[1] + w2 <- weights2[2] + do1 <- w1 != 0 + do2 <- w2 != 0 + NetJ <- if (do1 && do2) { + w1 * variability(x2) + w2 * (1 - gleichlauf(x2)) + } else if (do1) { + w1 * variability(x2) + } else if (do2) { + w2 * (1 - gleichlauf(x2)) + } else { + structure(rep.int(NA_real_, dimX[1]), names = rownames(x2)) + } Net <- mean(NetJ, na.rm = TRUE) list(all = NetJ, average = Net) } Modified: pkg/dplR/tests/testthat/test-dplR.R =================================================================== --- pkg/dplR/tests/testthat/test-dplR.R 2015-01-20 17:14:31 UTC (rev 943) +++ pkg/dplR/tests/testthat/test-dplR.R 2015-01-20 18:09:10 UTC (rev 944) @@ -611,7 +611,7 @@ seq.dec <- seq.int(from = -1, to = -10) testFrame2 <- data.frame(seq.inc, seq.inc, seq.inc, seq.dec) exp1 <- c(NA_real_, rep.int(2.25, 9)) - exp2 <- c(NA_real_, rep.int(2, 9)) + exp2 <- rep.int(2, 10) exp3 <- c(NA_real_, rep.int(0.25, 9)) expect_equal(net(testFrame2)[["all"]], exp1) expect_equal(net(testFrame2, weights=c(v=1, 0))[["all"]], exp2) From noreply at r-forge.r-project.org Wed Jan 21 10:10:37 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 21 Jan 2015 10:10:37 +0100 (CET) Subject: [Dplr-commits] r945 - www Message-ID: <20150121091037.404C2185546@r-forge.r-project.org> Author: mvkorpel Date: 2015-01-21 10:10:36 +0100 (Wed, 21 Jan 2015) New Revision: 945 Modified: www/index.php Log: Updated links Modified: www/index.php =================================================================== --- www/index.php 2015-01-20 18:09:10 UTC (rev 944) +++ www/index.php 2015-01-21 09:10:36 UTC (rev 945) @@ -43,7 +43,7 @@ -

See the intro page at Huxley Tree Ring Laboratory / Western Washington University.

+

See the intro page at Huxley Tree Ring Laboratory / Western Washington University.

The project summary page you can find here.

From noreply at r-forge.r-project.org Wed Jan 21 10:35:45 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 21 Jan 2015 10:35:45 +0100 (CET) Subject: [Dplr-commits] r946 - www Message-ID: <20150121093545.80AB018766B@r-forge.r-project.org> Author: mvkorpel Date: 2015-01-21 10:35:45 +0100 (Wed, 21 Jan 2015) New Revision: 946 Modified: www/index.php Log: Fixed image link Modified: www/index.php =================================================================== --- www/index.php 2015-01-21 09:10:36 UTC (rev 945) +++ www/index.php 2015-01-21 09:35:45 UTC (rev 946) @@ -26,7 +26,7 @@ +R-Forge Logo
-R-Forge Logo
From noreply at r-forge.r-project.org Wed Jan 21 13:50:29 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 21 Jan 2015 13:50:29 +0100 (CET) Subject: [Dplr-commits] r947 - pkg/dplR/tests/testthat Message-ID: <20150121125029.637DF1855B0@r-forge.r-project.org> Author: mvkorpel Date: 2015-01-21 13:50:29 +0100 (Wed, 21 Jan 2015) New Revision: 947 Modified: pkg/dplR/tests/testthat/test-dplR.R pkg/dplR/tests/testthat/test-io.R Log: Added some expected error message fragments Modified: pkg/dplR/tests/testthat/test-dplR.R =================================================================== --- pkg/dplR/tests/testthat/test-dplR.R 2015-01-21 09:35:45 UTC (rev 946) +++ pkg/dplR/tests/testthat/test-dplR.R 2015-01-21 12:50:29 UTC (rev 947) @@ -126,8 +126,8 @@ 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)) + expect_error(combine.rwl(list()),"nothing to combine",ignore.case=TRUE) + expect_error(combine.rwl(df.1), "nothing to combine", ignore.case=TRUE) }) test_that("combine.rwl works with a list of length one", { expect_equal(res.3, df.1) @@ -483,9 +483,9 @@ 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)) + expect_error(ffcsaps(y, f=-1), "between 0 and 1") + expect_error(ffcsaps(y, f=2), "between 0 and 1") + expect_error(ffcsaps(y, nyrs=0), "greater than 1") }) } test.ffcsaps() Modified: pkg/dplR/tests/testthat/test-io.R =================================================================== --- pkg/dplR/tests/testthat/test-io.R 2015-01-21 09:35:45 UTC (rev 946) +++ pkg/dplR/tests/testthat/test-io.R 2015-01-21 12:50:29 UTC (rev 947) @@ -10,7 +10,7 @@ fh) close(fh) test_that("read.tucson catches lines that are too long", { - expect_error(read.tucson(tf)) + expect_error(read.tucson(tf), "failed to read") }) ## Precision 0.01 @@ -107,7 +107,7 @@ "TEST8A 1730 1230 456 789 12 34 999"), fh8) close(fh8) test_that("read.tucson stops on overlapping data", { - expect_error(read.tucson(tf8)) + expect_error(read.tucson(tf8), "failed to read") }) ## Non-standard file with missing decade From noreply at r-forge.r-project.org Wed Jan 21 16:49:05 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 21 Jan 2015 16:49:05 +0100 (CET) Subject: [Dplr-commits] r948 - in pkg/dplR: . R Message-ID: <20150121154906.0E8CD18753F@r-forge.r-project.org> Author: mvkorpel Date: 2015-01-21 16:49:05 +0100 (Wed, 21 Jan 2015) New Revision: 948 Modified: pkg/dplR/ChangeLog pkg/dplR/DESCRIPTION pkg/dplR/NAMESPACE pkg/dplR/R/ffcsaps.R Log: Improved performance of ffcsaps() by using sparce matrices from the Matrix package. A quick test reveals that ffcsaps(rnorm(300000)) on the new version is faster than ffcsaps(rnorm(3000)) on the previous version. Modified: pkg/dplR/ChangeLog =================================================================== --- pkg/dplR/ChangeLog 2015-01-21 12:50:29 UTC (rev 947) +++ pkg/dplR/ChangeLog 2015-01-21 15:49:05 UTC (rev 948) @@ -23,6 +23,7 @@ --------------- - Importing captureOutput() from R.utils. +- Importing package Matrix. - Exporting net(). Various .R files @@ -34,6 +35,12 @@ corr.rwl.seg(), and corr.series.seg() does not have (undocumented) column names anymore. +File: ffcsaps.R +--------------- + +- Increased performance by using sparse matrices from the Matrix + package. + File: latexify.R ---------------- Modified: pkg/dplR/DESCRIPTION =================================================================== --- pkg/dplR/DESCRIPTION 2015-01-21 12:50:29 UTC (rev 947) +++ pkg/dplR/DESCRIPTION 2015-01-21 15:49:05 UTC (rev 948) @@ -3,7 +3,7 @@ Type: Package Title: Dendrochronology Program Library in R Version: 1.6.3 -Date: 2015-01-20 +Date: 2015-01-21 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", @@ -19,8 +19,9 @@ Maintainer: Andy Bunn Depends: R (>= 2.15.0) Imports: graphics, grDevices, grid, stats, utils, lattice (>= 0.13-6), - digest (>= 0.2.3), gmp (>= 0.5-5), png (>= 0.1-1), R.utils (>= - 1.32.0), stringi (>= 0.2-2), stringr (>= 0.4), XML (>= 2.1-0) + Matrix, digest (>= 0.2.3), gmp (>= 0.5-5), 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, testthat (>= 0.8), tikzDevice, waveslim Description: This package contains functions for performing tree-ring Modified: pkg/dplR/NAMESPACE =================================================================== --- pkg/dplR/NAMESPACE 2015-01-21 12:50:29 UTC (rev 947) +++ pkg/dplR/NAMESPACE 2015-01-21 15:49:05 UTC (rev 948) @@ -31,6 +31,8 @@ importFrom(utils, head, installed.packages, read.fwf, tail, packageVersion, write.table) +import(Matrix) + importFrom(XML, xmlEventParse) export(autoread.ids, bai.in, bai.out, ccf.series.rwl, chron, cms, Modified: pkg/dplR/R/ffcsaps.R =================================================================== --- pkg/dplR/R/ffcsaps.R 2015-01-21 12:50:29 UTC (rev 947) +++ pkg/dplR/R/ffcsaps.R 2015-01-21 15:49:05 UTC (rev 948) @@ -111,10 +111,10 @@ c(0, 0, odx[-1])), arg2, n) R2[, 1] <- R2[, 1] - 1 - forR <- matrix(0, zz2, zz2) - forR2 <- matrix(0, zz2, n) - forR[R[, 1] + (R[, 2] - 1) * zz2] <- R[, 3] - forR2[R2[, 1] + (R2[, 2] - 1) * zz2] <- R2[, 3] + forR <- Matrix(0, zz2, zz2, sparse = TRUE) + forR2 <- Matrix(0, zz2, n, sparse = TRUE) + forR[R[, 1:2, drop=FALSE]] <- R[, 3] + forR2[R2[, 1:2, drop=FALSE]] <- R2[, 3] ## The following order of operations was tested to be relatively ## accurate across a wide range of f and nyrs p.inv <- (1 - f) * (cos(2 * pi / nyrs) + 2) / @@ -124,8 +124,8 @@ mplier <- 6 - 6 / p.inv # slightly more accurate than 6*(1-1/p.inv) ## forR*p is faster than forR/p.inv, and a quick test didn't ## show any difference in the final spline - u <- solve(mplier * tcrossprod(forR2) + forR * p, - diff(diff(yi) / diff.xi)) + u <- as.numeric(solve(mplier * tcrossprod(forR2) + forR * p, + diff(diff(yi) / diff.xi))) yi <- yi - mplier * diff(c(0, diff(c(0, u, 0)) / diff.xi, 0)) test0 <- xi[-c(1, n)] c3 <- c(0, u / p.inv, 0) From noreply at r-forge.r-project.org Thu Jan 22 00:58:13 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 22 Jan 2015 00:58:13 +0100 (CET) Subject: [Dplr-commits] r949 - pkg/dplR Message-ID: <20150121235813.3D34D18575C@r-forge.r-project.org> Author: mvkorpel Date: 2015-01-22 00:58:12 +0100 (Thu, 22 Jan 2015) New Revision: 949 Modified: pkg/dplR/ChangeLog pkg/dplR/DESCRIPTION Log: Bumped up minimum version of R to 2.15.2 due to problems with R CMD check on earlier versions. Modified: pkg/dplR/ChangeLog =================================================================== --- pkg/dplR/ChangeLog 2015-01-21 15:49:05 UTC (rev 948) +++ pkg/dplR/ChangeLog 2015-01-21 23:58:12 UTC (rev 949) @@ -18,6 +18,8 @@ - Updated version requirement: gmp (>= 0.5-5). Earlier versions of gmp do not export is.bigq() which is required by dplR. The previous version requirement (>= 0.5-2) was a mistake. +- Updated version requirement: R (>= 2.15.2). For some reason, R + CMD check does not play nice with testthat on earlier versions of R. File: NAMESPACE --------------- Modified: pkg/dplR/DESCRIPTION =================================================================== --- pkg/dplR/DESCRIPTION 2015-01-21 15:49:05 UTC (rev 948) +++ pkg/dplR/DESCRIPTION 2015-01-21 23:58:12 UTC (rev 949) @@ -3,7 +3,7 @@ Type: Package Title: Dendrochronology Program Library in R Version: 1.6.3 -Date: 2015-01-21 +Date: 2015-01-22 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", @@ -17,7 +17,7 @@ Author: Andy Bunn [aut, cph, cre, trl], Mikko Korpela [aut, trl], Franco Biondi [aut, cph], Filipe Campelo [aut, cph], Pierre M?rian [aut, cph], Fares Qeadan [aut, cph], Christian Zang [aut, cph], Allan Buras [ctb], Jacob Cecile [ctb], Manfred Mudelsee [ctb], Michael Schulz [ctb] Copyright: Authors and Aalto University (for work of M. Korpela) Maintainer: Andy Bunn -Depends: R (>= 2.15.0) +Depends: R (>= 2.15.2) Imports: graphics, grDevices, grid, stats, utils, lattice (>= 0.13-6), Matrix, digest (>= 0.2.3), gmp (>= 0.5-5), png (>= 0.1-1), R.utils (>= 1.32.0), stringi (>= 0.2-2), stringr (>= 0.4), XML From noreply at r-forge.r-project.org Thu Jan 22 01:27:47 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 22 Jan 2015 01:27:47 +0100 (CET) Subject: [Dplr-commits] r950 - pkg/dplR Message-ID: <20150122002747.9506C184FA3@r-forge.r-project.org> Author: mvkorpel Date: 2015-01-22 01:27:47 +0100 (Thu, 22 Jan 2015) New Revision: 950 Modified: pkg/dplR/DESCRIPTION Log: Added version requirement for Matrix. Some earlier versions would not install. Modified: pkg/dplR/DESCRIPTION =================================================================== --- pkg/dplR/DESCRIPTION 2015-01-21 23:58:12 UTC (rev 949) +++ pkg/dplR/DESCRIPTION 2015-01-22 00:27:47 UTC (rev 950) @@ -19,9 +19,9 @@ Maintainer: Andy Bunn Depends: R (>= 2.15.2) Imports: graphics, grDevices, grid, stats, utils, lattice (>= 0.13-6), - Matrix, digest (>= 0.2.3), gmp (>= 0.5-5), png (>= 0.1-1), - R.utils (>= 1.32.0), stringi (>= 0.2-2), stringr (>= 0.4), XML - (>= 2.1-0) + Matrix (>= 1.0-3), digest (>= 0.2.3), gmp (>= 0.5-5), 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, testthat (>= 0.8), tikzDevice, waveslim Description: This package contains functions for performing tree-ring From noreply at r-forge.r-project.org Thu Jan 22 10:21:27 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 22 Jan 2015 10:21:27 +0100 (CET) Subject: [Dplr-commits] r951 - pkg/dplR/man Message-ID: <20150122092127.71E3C183E18@r-forge.r-project.org> Author: mvkorpel Date: 2015-01-22 10:21:27 +0100 (Thu, 22 Jan 2015) New Revision: 951 Modified: pkg/dplR/man/dplR-package.Rd Log: Credits to Allan Buras Modified: pkg/dplR/man/dplR-package.Rd =================================================================== --- pkg/dplR/man/dplR-package.Rd 2015-01-22 00:27:47 UTC (rev 950) +++ pkg/dplR/man/dplR-package.Rd 2015-01-22 09:21:27 UTC (rev 951) @@ -30,7 +30,8 @@ Zang. Function \code{\link{redfit}} is an improved translation of program REDFIT which is original work of Manfred Mudelsee and Michael Schulz. Jacob Cecile contributed a bug fix to - \code{\link{detrend.series}}. + \code{\link{detrend.series}}. Allan Buras came up with the revised + formula of \code{\link{glk}} in dplR >= 1.6.1. } \references{ Cook, E. R. and Kairiukstis, L. A. (1990) \emph{Methods of From noreply at r-forge.r-project.org Wed Jan 28 14:41:45 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 28 Jan 2015 14:41:45 +0100 (CET) Subject: [Dplr-commits] r952 - in pkg/dplR: . R Message-ID: <20150128134145.181271869CE@r-forge.r-project.org> Author: mvkorpel Date: 2015-01-28 14:41:44 +0100 (Wed, 28 Jan 2015) New Revision: 952 Modified: pkg/dplR/ChangeLog pkg/dplR/DESCRIPTION pkg/dplR/NAMESPACE pkg/dplR/R/net.R pkg/dplR/R/pointer.R pkg/dplR/R/rwl.stats.R Log: New imported package "matrixStats". Using its functions to speed up operations on the rows or columns of matrices, e.g. colMedians(), rowSds(). For example, the mean running time (on a particular computer) of net(ca533.rwi) as in ?net dropped from about 30 milliseconds to less than 6 milliseconds (measured with the "microbenchmark" package). Modified: pkg/dplR/ChangeLog =================================================================== --- pkg/dplR/ChangeLog 2015-01-22 09:21:27 UTC (rev 951) +++ pkg/dplR/ChangeLog 2015-01-28 13:41:44 UTC (rev 952) @@ -11,7 +11,7 @@ - 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 Imported packages: Matrix, matrixStats, R.utils. - New Suggested package: testthat. Unit tests are now done with testthat instead of RUnit. - RUnit is no longer Suggested. @@ -26,6 +26,7 @@ - Importing captureOutput() from R.utils. - Importing package Matrix. +- Importing various functions from matrixStats. - Exporting net(). Various .R files @@ -36,6 +37,8 @@ the $bins matrix in the return value of ccf.series.rwl(), corr.rwl.seg(), and corr.series.seg() does not have (undocumented) column names anymore. +- Using functions from the matrixStats package to speed up some + operations on the rows or columns of matrices. File: ffcsaps.R --------------- Modified: pkg/dplR/DESCRIPTION =================================================================== --- pkg/dplR/DESCRIPTION 2015-01-22 09:21:27 UTC (rev 951) +++ pkg/dplR/DESCRIPTION 2015-01-28 13:41:44 UTC (rev 952) @@ -3,7 +3,7 @@ Type: Package Title: Dendrochronology Program Library in R Version: 1.6.3 -Date: 2015-01-22 +Date: 2015-01-28 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", @@ -19,9 +19,9 @@ Maintainer: Andy Bunn Depends: R (>= 2.15.2) Imports: graphics, grDevices, grid, stats, utils, lattice (>= 0.13-6), - Matrix (>= 1.0-3), digest (>= 0.2.3), gmp (>= 0.5-5), png (>= - 0.1-1), R.utils (>= 1.32.0), stringi (>= 0.2-2), stringr (>= - 0.4), XML (>= 2.1-0) + Matrix (>= 1.0-3), digest (>= 0.2.3), gmp (>= 0.5-5), + matrixStats (>= 0.9.7), 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, testthat (>= 0.8), tikzDevice, waveslim Description: This package contains functions for performing tree-ring Modified: pkg/dplR/NAMESPACE =================================================================== --- pkg/dplR/NAMESPACE 2015-01-22 09:21:27 UTC (rev 951) +++ pkg/dplR/NAMESPACE 2015-01-28 13:41:44 UTC (rev 952) @@ -20,6 +20,8 @@ importFrom(lattice, panel.abline, panel.dotplot, panel.segments, trellis.par.set, xyplot) +importFrom(matrixStats, colMedians, colSds, rowSds) + importFrom(png, readPNG) importFrom(R.utils, captureOutput) Modified: pkg/dplR/R/net.R =================================================================== --- pkg/dplR/R/net.R 2015-01-22 09:21:27 UTC (rev 951) +++ pkg/dplR/R/net.R 2015-01-28 13:41:44 UTC (rev 952) @@ -14,7 +14,7 @@ } ## Standard deviation standardized by mean variability <- function(mat) { - Sd <- apply(mat, 1, sd, na.rm = TRUE) + Sd <- rowSds(mat, na.rm = TRUE) Mean <- rowMeans(mat, na.rm = TRUE) Sd / Mean } Modified: pkg/dplR/R/pointer.R =================================================================== --- pkg/dplR/R/pointer.R 2015-01-22 09:21:27 UTC (rev 951) +++ pkg/dplR/R/pointer.R 2015-01-28 13:41:44 UTC (rev 952) @@ -40,7 +40,7 @@ nat.y.2 <- pmax(0, out[, 4] - (nseries.thresh - 0.0000001)) out[, 5] <- sign(nat.y.1 - nat.y.2) out[, 6] <- (rowMeans(gv, na.rm=TRUE) - 1) * 100 - out[, 7] <- apply(gv, 1, function(x) sd(x, na.rm=TRUE)) * 100 + out[, 7] <- rowSds(gv, na.rm=TRUE) * 100 if (is.numeric(round.decimals) && length(round.decimals) > 0 && is.finite(round.decimals[1]) && round.decimals[1] >= 0) { for (i in c(3, 4, 6, 7)) { Modified: pkg/dplR/R/rwl.stats.R =================================================================== --- pkg/dplR/R/rwl.stats.R 2015-01-22 09:21:27 UTC (rev 951) +++ pkg/dplR/R/rwl.stats.R 2015-01-28 13:41:44 UTC (rev 952) @@ -14,18 +14,19 @@ yr <- as.numeric(row.names(rwl)) series.stats <- data.frame(series=names(rwl)) - the.range <- as.matrix(apply(rwl, 2, yr.range, yr.vec=yr)) + rwl2 <- as.matrix(rwl) + the.range <- as.matrix(apply(rwl2, 2, yr.range, yr.vec=yr)) series.stats$first <- the.range[1, ] series.stats$last <- the.range[2, ] series.stats$year <- series.stats$last - series.stats$first + 1 - series.stats$mean <- colMeans(rwl, na.rm=TRUE) - series.stats$median <- apply(rwl, 2, median, na.rm=TRUE) - series.stats$stdev <- apply(rwl, 2, sd, na.rm=TRUE) - series.stats$skew <- apply(rwl, 2, skew) - series.stats$sens1 <- apply(rwl, 2, sens1) - series.stats$sens2 <- apply(rwl, 2, sens2) - series.stats$gini <- apply(rwl, 2, gini.coef) - series.stats$ar1 <- apply(rwl, 2, acf1) + series.stats$mean <- colMeans(rwl2, na.rm=TRUE) + 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$gini <- apply(rwl2, 2, gini.coef) + series.stats$ar1 <- apply(rwl2, 2, acf1) seq.temp <- -seq_len(4) series.stats[, seq.temp] <- round(series.stats[, seq.temp], 3) From noreply at r-forge.r-project.org Wed Jan 28 15:12:54 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 28 Jan 2015 15:12:54 +0100 (CET) Subject: [Dplr-commits] r953 - in pkg/dplR: . R Message-ID: <20150128141254.8A82D183D7F@r-forge.r-project.org> Author: mvkorpel Date: 2015-01-28 15:12:54 +0100 (Wed, 28 Jan 2015) New Revision: 953 Modified: pkg/dplR/NAMESPACE pkg/dplR/R/common.interval.R Log: matrixStats speedup for common.interval() Modified: pkg/dplR/NAMESPACE =================================================================== --- pkg/dplR/NAMESPACE 2015-01-28 13:41:44 UTC (rev 952) +++ pkg/dplR/NAMESPACE 2015-01-28 14:12:54 UTC (rev 953) @@ -20,7 +20,8 @@ importFrom(lattice, panel.abline, panel.dotplot, panel.segments, trellis.par.set, xyplot) -importFrom(matrixStats, colMedians, colSds, rowSds) +importFrom(matrixStats, colAlls, colAnys, colMedians, colSds, rowAlls, + rowSds) importFrom(png, readPNG) Modified: pkg/dplR/R/common.interval.R =================================================================== --- pkg/dplR/R/common.interval.R 2015-01-28 13:41:44 UTC (rev 952) +++ pkg/dplR/R/common.interval.R 2015-01-28 14:12:54 UTC (rev 953) @@ -24,7 +24,7 @@ ## series with overlaps rm.short <- function(rwl, yrs, rwlNotNA, row.idx, flag=FALSE) { n <- 0 - anyNotNA <- apply(rwlNotNA, 2, any) + anyNotNA <- colAnys(rwlNotNA) which.good <- which(anyNotNA) nCol.orig <- length(which.good) series.range <- matrix(NA_real_, 2, nCol.orig) @@ -55,7 +55,7 @@ break } } - tmp <- apply(rwlNotNA[dontkeep.row, keep.col, drop = FALSE], 1, all) + tmp <- rowAlls(rwlNotNA[dontkeep.row, keep.col, drop = FALSE]) dontkeep.row[dontkeep.row] <- !tmp nRow <- nRow + sum(tmp) n.years <- nCol * nRow @@ -133,7 +133,7 @@ keep.row <- tmp[[3]] keep.col <- tmp[[4]] } else { # type2 == "both" - keep.col <- apply(rwlNotNA[row.idx, , drop = FALSE], 2, all) + keep.col <- colAlls(rwlNotNA[row.idx, , drop = FALSE]) nCol <- sum(keep.col) } opt <- nRow * nCol From noreply at r-forge.r-project.org Wed Jan 28 17:05:48 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 28 Jan 2015 17:05:48 +0100 (CET) Subject: [Dplr-commits] r954 - pkg/dplR/R Message-ID: <20150128160548.F1AFF1878A9@r-forge.r-project.org> Author: mvkorpel Date: 2015-01-28 17:05:48 +0100 (Wed, 28 Jan 2015) New Revision: 954 Modified: pkg/dplR/R/i.detrend.series.R pkg/dplR/R/read.crn.R pkg/dplR/R/rwi.stats.running.R pkg/dplR/R/series.rwl.plot.R pkg/dplR/R/wc.to.po.R Log: More matrix stats optimizations Modified: pkg/dplR/R/i.detrend.series.R =================================================================== --- pkg/dplR/R/i.detrend.series.R 2015-01-28 14:12:54 UTC (rev 953) +++ pkg/dplR/R/i.detrend.series.R 2015-01-28 16:05:48 UTC (rev 954) @@ -4,7 +4,7 @@ fits <- detrend.series(y, y.name, make.plot=TRUE, nyrs = nyrs, f = f, pos.slope = pos.slope) ## Remove the nec resids if all na - fits <- fits[, !apply(is.na(fits), 2, all), drop=FALSE] + fits <- fits[, !colAlls(is.na(fits)), drop=FALSE] col.names <- names(fits) cat(gettextf("\nChoose a detrending method for this series %s.\n", y.name, domain="R-dplR")) Modified: pkg/dplR/R/read.crn.R =================================================================== --- pkg/dplR/R/read.crn.R 2015-01-28 14:12:54 UTC (rev 953) +++ pkg/dplR/R/read.crn.R 2015-01-28 16:05:48 UTC (rev 954) @@ -118,7 +118,7 @@ ## Clean up NAs crn.mat[which(crn.mat[, -ncol.crn.mat] == 9990)] <- NA # column-major order crn.mat <- - crn.mat[!apply(is.na(crn.mat[, -ncol.crn.mat, drop=FALSE]), 1, all), + crn.mat[!rowAlls(is.na(crn.mat[, -ncol.crn.mat, drop=FALSE])), , drop=FALSE] ## If samp depth is all 1 then dump it Modified: pkg/dplR/R/rwi.stats.running.R =================================================================== --- pkg/dplR/R/rwi.stats.running.R 2015-01-28 14:12:54 UTC (rev 953) +++ pkg/dplR/R/rwi.stats.running.R 2015-01-28 16:05:48 UTC (rev 954) @@ -167,13 +167,13 @@ tree.any <- matrix(FALSE, n.years, n.trees) for (i in seq.tree) { tree.any[, i] <- - apply(rwiNotNA[, treeIds == unique.trees[i], drop=FALSE], 1, any) + rowAnys(rwiNotNA[, treeIds == unique.trees[i], drop=FALSE]) } n.trees.by.year <- rowSums(tree.any) ## Easy way to force complete overlap of data if (period2 == "common") { - bad.rows <- !apply(rwiNotNA, 1, all) + bad.rows <- !rowAlls(rwiNotNA) rwi3[bad.rows, ] <- NA rwiNotNA[bad.rows, ] <- FALSE good.rows.flag <- !bad.rows @@ -305,8 +305,7 @@ rbar.bt <- rsum.bt / n.bt } - coresPresent <- - which(apply(rwiNotNA[year.idx, , drop = FALSE], 2, any)) + coresPresent <- which(colAnys(rwiNotNA[year.idx, , drop = FALSE])) treesPresent <- unique(treeIds[coresPresent]) nCores <- length(coresPresent) nTrees <- length(treesPresent) Modified: pkg/dplR/R/series.rwl.plot.R =================================================================== --- pkg/dplR/R/series.rwl.plot.R 2015-01-28 14:12:54 UTC (rev 953) +++ pkg/dplR/R/series.rwl.plot.R 2015-01-28 16:05:48 UTC (rev 954) @@ -20,7 +20,7 @@ seg.lag <- seg.length / 2 - mask <- !apply(as.matrix(is.na(rwl2)), 1, all) + mask <- !rowAlls(as.matrix(is.na(rwl2))) yrs0 <- as.numeric(row.names(rwl2))[mask] ## Normalize. tmp <- normalize.xdate(rwl2, series2, n, prewhiten, biweight) Modified: pkg/dplR/R/wc.to.po.R =================================================================== --- pkg/dplR/R/wc.to.po.R 2015-01-28 14:12:54 UTC (rev 953) +++ pkg/dplR/R/wc.to.po.R 2015-01-28 16:05:48 UTC (rev 954) @@ -15,10 +15,8 @@ !is.na(missing)) pith.offset <- rep(as.integer(NA), n) pith.offset[not.na] <- - as.integer(apply(cbind(missing[not.na], unmeasured[not.na]), - 1, - sum, - na.rm = TRUE) + 1) + as.integer(rowSums(cbind(missing[not.na], unmeasured[not.na]), + na.rm = TRUE) + 1) data.frame(series = row.names(wc), pith.offset) From noreply at r-forge.r-project.org Wed Jan 28 17:10:08 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 28 Jan 2015 17:10:08 +0100 (CET) Subject: [Dplr-commits] r955 - pkg/dplR Message-ID: <20150128161008.2C5CA183C2B@r-forge.r-project.org> Author: mvkorpel Date: 2015-01-28 17:10:07 +0100 (Wed, 28 Jan 2015) New Revision: 955 Modified: pkg/dplR/ChangeLog pkg/dplR/NAMESPACE Log: Stuff forgotten from the previous commit Modified: pkg/dplR/ChangeLog =================================================================== --- pkg/dplR/ChangeLog 2015-01-28 16:05:48 UTC (rev 954) +++ pkg/dplR/ChangeLog 2015-01-28 16:10:07 UTC (rev 955) @@ -37,8 +37,8 @@ the $bins matrix in the return value of ccf.series.rwl(), corr.rwl.seg(), and corr.series.seg() does not have (undocumented) column names anymore. -- Using functions from the matrixStats package to speed up some - operations on the rows or columns of matrices. +- Using base::rowSums and functions from the matrixStats package + to speed up some operations on rows or columns of matrices. File: ffcsaps.R --------------- Modified: pkg/dplR/NAMESPACE =================================================================== --- pkg/dplR/NAMESPACE 2015-01-28 16:05:48 UTC (rev 954) +++ pkg/dplR/NAMESPACE 2015-01-28 16:10:07 UTC (rev 955) @@ -21,7 +21,7 @@ trellis.par.set, xyplot) importFrom(matrixStats, colAlls, colAnys, colMedians, colSds, rowAlls, - rowSds) + rowAnys, rowSds) importFrom(png, readPNG)