From noreply at r-forge.r-project.org Sat Jan 11 07:29:53 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sat, 11 Jan 2014 07:29:53 +0100 (CET) Subject: [Dplr-commits] r718 - in pkg/dplR: . R Message-ID: <20140111062953.BC58A186A27@r-forge.r-project.org> Author: andybunn Date: 2014-01-11 07:29:53 +0100 (Sat, 11 Jan 2014) New Revision: 718 Modified: pkg/dplR/ChangeLog pkg/dplR/R/tbrm.R Log: trying to track down error when R CMD check --as-cran dplR_1.5.8.tar.gz is called. Modified: pkg/dplR/ChangeLog =================================================================== --- pkg/dplR/ChangeLog 2013-11-27 10:28:42 UTC (rev 717) +++ pkg/dplR/ChangeLog 2014-01-11 06:29:53 UTC (rev 718) @@ -1,2220 +1,2228 @@ -* CHANGES IN dplR VERSION 1.5.8 - -File: DESCRIPTION - -- Added Jacob Cecile as a contributor - -File: detrend.R ---------------- - -- Adjusted for the changes in detrend.series(), - i.e. added the argument constrain.modnegexp. - -File: detrend.series.R ----------------------- - -- Fixed a bug where RWI could go negative. Thanks to Jacob Cecile for - reporting the bug and contributing a proposed solution. -- A new argument: constrain.modnegexp. It is now possible to constrain - the modified negative exponential function to non-negative values at - infinity. - -File: redfit.R --------------- - -- Use slightly faster .rowSums() instead of rowSums() -- Simplified arithmetic expressions in getdof(): no multiplying by 2 -- Precomputed squared numbers in getdof() -- Fixed Welch, Hanning, Triangular and Blackman-Harris windows to - be DFT-even -- Computed more precise values for the 6 dB bandwidths of each window, - also for short windows. Uniform sampling was assumed. -- Two internal functions moved to top level, previously inside print.redfit() - -* CHANGES IN dplR VERSION 1.5.7 - -File: DESCRIPTION ------------------ - -- Import gmp (>= 0.5-2) - -File: NAMESPACE ---------------- - -- New imports from gmp and utils -- Export redfit() and runcrit() - -Various .R files ----------------- - -- Check that length of vector does not overflow integer datatype - before use of .C() -- Avoid possible name clashes when using foreach with parallel backends - -File: common.interval.R ------------------------ - -- Optimizations (for example, less subsetting of the 'rwl' data.frame) -- Better handling of corner cases (zero dimensions etc.) -- In the plot (make.plot = TRUE), length of lines was adjusted: - First year a, last year b is 'b - a + 1' years, not 'b - a' years - -File: corr.rwl.seg.R --------------------- - -- New feature: allow the master series to be built from a second set of - tree ring series by using a data.frame 'master' argument -- Replaced some for loops with cleaner vectorized operations or apply(). - -File: helpers.R ---------------- - -- Fixed a bug in fix.names(), related to creating unique short names. - The bug affected read.tridas(), write.compact(), write.tridas() and - write.tucson() but probably manifested itself quite rarely. - -File: rwi.stats.running.R -------------------------- - -- Speedup by using rep.int() instead of rep() - -File: sea.R ------------ - -- Extra input checks (e.g. x must have explicit, non-automatic row-names) -- Some matrices now have the correct type (numeric instead of logical) - right from the beginning -- Small optimization: a temporary matrix is completely overwritten on - every round of a loop, so no need to reinitialize -- Braces always used in if (else) constructs - -Files: redfit.R, redfit.c -------------------------- - -- New function redfit() based on REDFIT by Schulz and Mudelsee. Also - another exported function runcrit(). - - -* CHANGES IN dplR VERSION 1.5.6 - -File: write.tucson.R ------------------------- - -- Changed series IDs to justify left instead of right. I'm not sure why - they ever wanted to be justified left. Silly. (AGB) - -File: NAMESPACE ---------------- -- Exporting new function common.interval() - -File: common.interval.R ------------------------- - -- New function common.interval() trims a rwl object to a common interval - using one of three methods. Contributed by a user Filipe Campelo (fcampelo at ci.uc.pt). - This is his first contribution. Added to author list in DESCRIPTION. - -File: corr.rwl.seg.R --------------------- - -- Bug fix: series names were not shown (numbers were shown instead) -- Bug fix: there were off-by-one errors in the length of the bars - -File: DESCRIPTION ------------------ -- Changed author and maintainer to Andy Bunn from Andrew G. Bunn to keep parity between - the names and the email address AGB uses to submit to CRAN. This was made at the - request of Kurt Hornik at CRAN - -* CHANGES IN dplR VERSION 1.5.5 - -File: NAMESPACE ---------------- - -- Exporting new functions - -Various .R files: ------------------ - -- Use 'nzchar(x)' instead of 'nchar(x) > 0' - -File: rwi.stats.running.R -------------------------- - -- Added prewhitening option to rwi.stats.running() and by extension rwi.stats(). - There are two new arguments prewhiten and n that are passed to normalize1() - as in the xdating functions e.g., corr.rwl.seg(). Help file changed. - -Files: corr.rwl.seg.R, seg.plot.R, rwl.stats.R, spag.plot.R ------------------------------------------------------------ - -- Support for input of length 1 - - -File: corr.rwl.seg.R --------------------- - -- Fixed 'ylim' in plot() -- Fixed "no guides" case -- stops with a clear error message if 'rwl' has too few rows for the given - 'seg.length' and 'bin.floor' combination - -File: fill.internal.NA.R ------------------------- - -- New function fill.internal.NA() fills NA values internal to a series. - Written by Andy Bunn and Mikko Korpela. Help page added as well. - -File: pointer.R ---------------- - -- New function pointer() calculates pointer years from a group of - ring-width series. Written by Pierre M?rian, adapted for dplR and - improved by Andy Bunn and Mikko Korpela. Help page added as well. - -File: rcs.R ------------ - -- Graceful handling of empty input - -File: read.compact.R --------------------- - -- Pretty printing of summary output, no more ragged lines - -File: read.fh.R ---------------- - -- Pretty printing of summary output, no more ragged lines -- More robust detection of block and single column data representations -- Data block, when using block representation, is interpreted as fixed - width fields (10*6)). Reference: TRiCYCLE Users Manual, Version 0.2.6. -- Different units are supported. Default is 1/100 mm. -- Each data block is mapped to the correct header block. Previously, there - was a risk of using the wrong header if the file contained data in - formats other than "Tree" or "Single". Also, the end position - of any data block could be off if data with different formats was - present in the file. Presumably the function would have failed with an - obscure error message. -- Added support for site, tree, core, etc. metadata. Results are given as - an attribute of the return value, named "ids". -- Added support for MissingRingsBefore (pith offset) metadata. Results are - given as an attribute named "po". - -File: read.tucson.R -------------------- - -- Fixed trimming of all-NA rows -- Fixed a bug that could crash R if the fided-width columns of the input - file did not follow the (loose) specifications of the Tucson format -- AB: Note to dplR developers that this is a result of a poor standard in - the Tucson format but this fix is needed to work with files that are - on the ITRDB. Interestingly, dpl and ARSTAN are more robust to these - kinds of inconsistencies. Mikko's note: always check that your - assumptions a piece of input are correct before using the said input - to compute array indices, particularly in C code. -- Can deal with CR CR LF newlines by reading the whole file into memory - at first and stripping empty lines -- Can read non-standard files where one or more of the stop markers is - the 11th data column of its row -- Can read non-standard files where columns don't have their proper - widths, including tab-delimited files -- Can read non-standard files where missing data is marked with - non-numeric characters -- Printed summary is justified, no more ragged lines -- Interprets lines containing "#" characters (in positions 1-78) as - comments. For now, comments are ignored. -- Fixed a bug that could cause mixing of values from two or more - measurement series sharing the same ID. Now it is an error if the input - file contains more than one measurement for any year, ID pair. -- Accommodate mid-series upper and lower case differences: If a series - does not end with a stop marker, see if the series ID of the next row - after the last belonging to the series without a stop marker matches - when case differences are ignored. If so, interpret these as the same - series. - -File: write.tucson.R --------------------- - -- Instead of always using 1000, 999 is now randomly converted to either - 998 or 1000 (prec == 0.01) => no bias (even if small) - -* CHANGES IN dplR VERSION 1.5.4 - -File: DESCRIPTION ------------------ - -- Depends: R (>= 2.15.0) to accommodate use of .filled.contour() in - wavelet.plot(). Also enables the use of paste0(). - -File: NAMESPACE ---------------- - -- Imports from package stringr (also in DESCRIPTION) -- Exports new function autoread.ids() - -Various .R files ----------------- - -- use paste0(...) instead of paste(..., sep="") -- prettier, more consistent formatting of source code - -File: helpers.R ---------------- - -- New internal function check.flags() requires that its arguments are TRUE - or FALSE - -File: read.ids.R ----------------- - -- Optional automatic detection of the site-tree-core scheme (stc="auto") -- Optional fixing of typos in series names -- Optional (adaptive) case insensitivity -- New wrapper function autoread.ids() calls read.ids with stc="auto" and - an alternative set of parameter values - -File: read.tucson.R -------------------- - -- More robust detection of header - -File: wavelet.plot.R --------------------- - -- Switched from using an .Internal() call to using new bare-bones - function .filled.contour() for the plotting. This is at the - request of Prof. Ripley who wrote that 'Packages should not call - .Internal(): it is not part of the API, for use only by R itself - and subject to change without notice.' In 1.5.3, the use of - .Internal() or .filled.contour() was an if-else decision based on - the version of R, but now the latter function is always used, - making R >= 2.15.0 required. -- enabled translation of default value of 'key.lab' -- checks 'wave.list$x' and 'wave.list$period' - -Files: write.compact.R, write.tucson.R --------------------------------------- - -- Useless uses of eval() removed - -2012-03-05 Andy Bunn -* CHANGES IN dplR VERSION 1.5.3 - -File: CITATION --------------- - -- Uses the new bibentry() style -- Has an automatic entry for the dplR manual (R >= 2.14.0 requirement) -- Entry for "Statistical and visual crossdating in R using the dplR - library" was updated - -File: DESCRIPTION ------------------ - -- Encoding: UTF-8 -- Depends: R (>= 2.14.0) -- Author and Maintainer fields dropped (made obsolete by Authors at R) - -File: NAMESPACE ---------------- - -- import() or importFrom() from all the "base" Priority packages - that are used in dplR. Previously, the use of functions from those - packages seems to have relied on the assumption of them being - attached. - - Quote from "Writing R Extensions": - "Packages implicitly import the base namespace. Variables exported - from other packages with namespaces need to be imported explicitly - using the directives import and importFrom." - - Clearly, packages with Priority "base" (different from the package / - namespace called "base") fall into the category of "other packages". - -- importFrom() used in more cases - -- exports rwi.stats.legacy() - -File: powt.R ------------- - -- New function for power transformation after Cook and Peters - -File: rcs.R ------------ - -- Allows for standardization by subtraction - -Files: read.crn.R, read.tucson.R --------------------------------- - -- Fix handling of (effectively) empty lines (thanks to Heather - Gamper for reporting) - -File: rwi.stats.R ------------------ - -- rwi.stats() was renamed to rwi.stats.legacy(), potentially useful for - comparing the results of the old and new code - -File: rwi.stats.running.R -------------------------- - -- zero.is.missing now has default value TRUE -- rwi.stats() is now a wrapper to rwi.stats.running() -- allows 'ids' to have extra rows if all names of 'rwi' appear as its row - names - -File: strip.rwl.R ------------------ - -- New function for EPS-based chronology stripping - -File: wavelet.plot.R --------------------- - -- Replaces .Internal(filledcontour) with .filled.contour in R >= 2.15.0 - -2012-01-19 Mikko Korpela -* CHANGES IN dplR VERSION 1.5.2 - -- Requires R >= 2.12.0 (use of markup in some Rd \title{} sections). -- Documentation has been cleaned up / uses better markup. - -File: ffcsaps.R ---------------- - -- Checks that 'x' and 'y' are coercible to _numeric_ vectors - -File: read.ids.R ----------------- - -- Checks that 'stc' contains nothing but integral values and has length 3 - -Files: write.compact.R, write.tridas.R, write.tucson.R ------------------------------------------------------- - -- Accept unknown arguments ('...') - -2011-12-19 Mikko Korpela -* CHANGES IN dplR VERSION 1.5.1 - -File: corr.rwl.seg.R --------------------- - -- New parameters 'master' and 'master.yrs': Instead of letting - corr.rwl.seg() compute master series based on 'rwl', the user can use - her own master series. -- Ensures that rwl (and master) have consecutive years in increasing order -- Uses full form "greater" instead of "g" in calls to cor.test() - -File: corr.series.seg.R ------------------------ - -- Uses full form "greater" instead of "g" in calls to cor.test() - -2011-11-23 Mikko Korpela -* CHANGES IN dplR VERSION 1.5.0 - -Various .R files: ------------------ - -- Use TRUE instead of T -- sapply() replaced with vapply() or vectorized operations - -File: detrend.series.R ----------------------- - -- Checks that there are no NAs in the middle of the series. Series from - dplR rwl data.frames don't have mid-series NAs (unless manipulated by - the user), but other data might. - -File: read.crn.R ----------------- - -- Calls to read.fwf() now set the colClasses parameter. This gives - more predictable behavior when the input file contains non-integer - data where integers are expected. That is,.the function stops with - a clear error message, whereas previously, the resulting data.frame - would have contained seemingly random zeros. -- Some optimizations (vectorization, less copying, etc.) -- In the non-standard situation of multiple series per file, the previous - versions assumed the same range of years for all series. This rule, - breaking of which would give strange results, no longer applies. - -File: read.fh.R ---------------- - -- Replaced read.csv() with readLines() -- Unnecessary captures removed from regular expressions -- Small optimizations (e.g., positions() was replaced with a more - efficient solutions) -- The possibly dangerous removal of zeros, even from the middle of - series, was rewritten -- Gives a clear error message when a data series has unexpected length -- Handles empty files / files with zero records better - -File: read.tucson.R -------------------- - -- Calls to read.fwf() now set the colClasses parameter (see explanation - above) - -File: rwi.stats.running.R -------------------------- - -- Fixes a bug where the function would not work if 'ids' was NULL - -2011-11-14 Mikko Korpela -* CHANGES IN dplR VERSION 1.4.9 - -File: rcompact.c ----------------- - -- read.compact() now accepts series IDs consisting of any sequence of - printable ASCII characters. - -2011-11-06 Mikko Korpela -* CHANGES IN dplR VERSION 1.4.8 - -File: NAMESPACE ---------------- - -- Made some internal functions truly internal by removing them from the - export list - -File: dplR-internal.Rd ----------------------- - -- The file was removed - -Various .c and .h files: ------------------------- - -- NULL, TRUE and FALSE are used for clarity -- Rboolean type is now used more extensively for truth values -- stddef.h is #included where NULL is used - -Various .R files: ------------------ - -- When indexing data.frames, use df[[foo]][bar] instead of df[bar, foo] - when foo is a single index (or df$foo[bar] instead of df[bar, "foo"]). - The former is supposed to be faster than the latter. - https://stat.ethz.ch/pipermail/r-devel/2011-October/062313.html -- Some input checks added - -File: combine.rwl.R -------------------- - -- Avoids some conversions between matrix and data.frame - -File: ffcsaps.R ---------------- - -- For loop removed in ffppual (constant number of iterations) -- Useless instances of cbind() and rbind() removed -- Avoids computing or passing as arguments things that are already known - or constant -- ffsorted2() is a modified version of ffsorted() which should speed - things up a little by making a rev() call unnecessary -- Unnecessary call to pmax() removed -- Added some input checks -- order() is now used instead of sort(method="shell"), because the - requirements for the latter being a stable sort are unclear - (?sort in R 2.13.2), and stability of the sort is required - in some parts of ffcsaps (may be desirable in others) - -File: normalize1.R ------------------- - -- For consistency, the first part of the returned list is now a - matrix regardless of the value of 'prewhiten'. This also gives an - amazing speed improvement in corr.rwl.seg: from 42 seconds to 1 - second in the ?corr.rwl.seg Example, modified with - prewhiten=FALSE, make.plot=FALSE. This corrects the performance - degradation introduced in dplR 1.2.7. Tested on a computer with a - Core 2 processor, 3.0 GHz. - -File: rcompact.c ----------------- - -- Now accepts series IDs with spaces. - -File: seg.plot.R ----------------- - -- Uses order() and numeric indexing instead of sort() and indexing with - names - -File: skel.plot.R ------------------ - -- Replaced one for loop with vectorized operations - -File: spag.plot.R ----------------- - -- Uses order() and numeric indexing instead of sort() and indexing with - names - -2011-09-14 Mikko Korpela -* CHANGES IN dplR VERSION 1.4.7 - -Various .R files: ------------------ - -- For data.frames, row.names() is now used instead of rownames(). - The opposite change was applied in one location (not a data.frame). - Also, names() is used instead of colnames() where appropriate. - This is because names() and row.names() are preferred to - colnames() and rownames(), respectively, when dealing with data.frames. - -File: read.ids.R ----------------- - -- Fixed a bug introduced in dplR 1.4.1 where the function would not work - for non-numeric identifiers or when identifiers did not fall in the - range from 1 to n. - -- Now respects input identifiers where possible: If all substrings - denoting tree or core are integers, they are used. Otherwise, - sorted unique identifiers (number of which is n.unique) are mapped - to numbers 1:n.unique. - -- Now allows the sum of the site-tree-core mask to be smaller than 8. - The remaining characters will be ignored. This can be handy if there are - additional levels in the ID hierarchy. Then, the series with matching - ID strings up to the sum of the site-tree-core mask will be given - matching tree and core numbers. - -File: rwi.stats.running.R -------------------------- - -- Now averages data from series with the same tree/core ID combination - before computing any statistics. - -- Now has the option to treat zeros as missing data (parameter - zero.is.missing). Defaults to FALSE which gives identical results - compared to previous versions of the function, but should probably be - set to TRUE for most purposes. - -2011-09-01 Mikko Korpela -* CHANGES IN dplR VERSION 1.4.6 - -File: corr.rwl.seg.R --------------------- - -- Fixed a bug in the $flags part of the list returned by the - function. Previously, a single flagged segment / series was not - reported. - -File: corr.series.seg.R ------------------------ - -- Fixed a bug where moving correlations were computed using a window one - year longer than seg.length. This problem had gone unnoticed when - fixing some related bugs for version 1.4.5. -- Changed the x and y limits of the plot. Now the computation of the y - limits does not use p-values as an input (the y-axis is correlation, not - p-value). x limits are now set explicitly, and generally speaking there - is more space around the plotted data. - -2011-08-11 Mikko Korpela -* CHANGES IN dplR VERSION 1.4.5 - -Various .R files: ------------------ - -- Updates to sequence generation, e.g. use seq_along and seq_len where - applicable - -Files: ccf.series.rwl.R, corr.rwl.seg.R, corr.series.seg.R, series.rwl.plot.R ------------------------------------------------------------------------------ - -A bunch of related bugs were fixed, some not present or already -(partially) fixed in some files: -- Fixed a bug where segment length was always actually one year longer - than the specified seg.length (not in corr.rwl.seg.R, corr.series.seg.R). -- Fixed a bug where the requirement of fitting at least two segments - did not take into account overlapping segments (seg.lag), therefore - requiring more than the minimum number of years (not in corr.rwl.seg.R). - Note: qa.xdate() still requires nrow(rwl) >= seg.length*2. -- Added a "plus 1" option (floor.plus1) to location of first segment. - Works together with parameter bin.floor. Default value is FALSE. - -- In corr.rwl.seg.R, cleaned up the code and fixed some bugs related to - segment boundaries. -- In corr.rwl.seg.R, fixed a bug where multiple disconnected red segments - were not drawn correctly. -- In corr.rwl.seg.R, removed unused variables / operations -- In corr.rwl.seg.R and corr.series.seg.R, arguably prettier x axis ticks - and labels are used (now separated by seg.length). -- In corr.series.seg.R, an additional error check was added - -File: tbrm.c ------------- - -- "Nothing to sum" case, when there are some numbers but all are too far - from median, returns NaN instead of NA. Finally, this is consistent - with tbrm() coded in R, prior to dplR 1.2.7. - -File: write.compact.R ---------------------- - -- Fixed two precedence issues that luckily didn't result in erroneous - behaviour of the function - -2011-07-03 Mikko Korpela -* CHANGES IN dplR VERSION 1.4.4 -* Changes in documentation will not be reported anymore - -Various .R files: ------------------ - -- Parameters not changed by assignment anymore (complaint by - codetools). Applies to direct assignment; assign() etc go unnoticed by - codetools. - -File: ccf.series.rwl.R ----------------------- - -- Cosmetic changes (white spaces, assignment operator) -- Parameter 'cex' is given in the call to xyplot, like 'col.line'. Both go - to 'panel' in '...'. -- Parameter 'col' removed from function 'panel' -- Some extra steps are taken because we want to ensure correct operation - now when formal parameters are not changed by assignment -- (1 + 1 - pcrit) / 2 == 1 - pcrit / 2 (at least within floating point - precision), so we use the latter which is a simpler form - -File: chron.R -------------- - -- Argument checking updated - -File: corr.series.seg.R ------------------------ - -- Some extra steps are taken like in ccf.series.rwl.R -- (1 + 1 - pcrit) / 2 == 1 - pcrit / 2 - -File: detrend.R ---------------- - -- Parameter 'f' now has an explicit default value - -File: detrend.series.R ----------------------- - -- Unnecessary double checking of 'method' argument removed -- Parameters 'f' and 'y.name' now have explicit default values -- Graphical parameters are reset on.exit() - -File: ffcsaps.R ---------------- - -- Uses complete parameter names in calls to sort - -File: glk.R ------------ - -- Large parts rewritten -- 'glk(ca533)' example in glk.Rd runs about 100 times faster -- Now explicitly requires that the non-NA overlap between series be - contiguous, which should be true in dplR. This was not checked in - previous versions. - -File: hanning.R ---------------- - -- Slightly more efficient computation - -File: i.detrend.R ------------------ - -- Parameter 'f' now has an explicit default value - -File: i.detrend.series.R ------------------------- - -- Parameter 'f' now has an explicit default value -- Fixed a bug where the values of the parameters 'f', 'nyrs' and - 'pos.slope' were not reflected in the returned result, only in the - picture. -- Saved result is used instead of detrending twice (once with all methods, - then with selected method) -- "Enter a number" is asked until a valid number is received. Normal - interrupt sequences work. - -File: morlet.R --------------- - -- Removed 'param' and made 'k0=6' an explicit default in morlet.func() -- seq(from=1, to=n) - 1 == seq(from=0, to=n-1) -- log2(x) instead of log(x) / log(2) -- Cosmetic changes - -File: series.rwl.plot.R ------------------------ - -- Some extra steps are taken like in ccf.series.rwl.R -- Graphical parameters are reset on.exit() - -File: wavelet.plot.R --------------------- - -- log2(x) instead of log(x) / log(2) - -File: write.tridas.R --------------------- - -- Fixed a bug in the handling of parameter 'crn.units' - -2011-07-01 Mikko Korpela -* CHANGES IN dplR VERSION 1.4.3 -* Changes below by Mikko Korpela - -Directory: po -------------- - -- A new directory used for language translations -http://cran.r-project.org/doc/manuals/R-exts.html#Internationalization - -Directory: inst/po ------------------- - -- Location for compiled translations - -Directory: inst/po/fi and contents ---------------------- - -- Compiled Finnish translations - -Various .R files: ------------------ - -- Diagnostic and normal output messages were edited to facilitate - translations. Messages consist of logical units (no small fragments, but - sequences of sentences is possible), and gettext() and - gettextf() are used. Also plot labels, titles and legends are ready for - translation - -File: po/R-dplR.pot -------------------- - -- A translation template for messages in R code - -File: po/dplR.pot -------------------- - -- A translation template for messages in C code - -File: po/R-fi.po ----------------- - -- Finnish translations of messages in R code - -File: po/fi.po --------------- - -- Finnish translations of messages in C code - -File: src/dplR.h ----------------- - -- A new file that (initially) contains definitions used for looking up - translations of messages appearing in C code - -File: src/rcompact.c --------------------- - -- Supports translation of messages via _(...), where ... is the string to - translate - -File: DESCRIPTION ------------------ - -- Added a link to the R-Forge dplR development page - -File: cms.R ------------ - -- Better checking of pith offset names -- Big performance improvement, mostly due to using vector operations - instead of a for loop -- Results slightly different (on the order of 1e-15) due to polyroot - having been replaced with quadratic formula, order of arithmetic - operations etc. -- Helper function now has 2 parameters: no need for cbind() in caller - -File: corr.rwl.seg.R --------------------- - -- Additional parameter in yr.range() -- First definition of segavg.cor was not used. Now removed. -- Some unnecessary name assignments and conversions to data.frame removed - -File: detrend.series.R ----------------------- - -- Fixed a bug caused by incorrect syntax in named argument (was <- in - 1.4.1 and 1.4.2, correct form is =). ModNegExp detrending works - again. - -File: glk.R ------------ - -- Uses the complete argument name MARGIN instead of MAR - -File: helpers.R ---------------- - -- Additional parameter in yr.range(). Used by all callers. - -File: rcs.R ------------ - -- Uses warning() instead of cat() in one (unlikely?, impossible?) error - situation -- Better checking of pith offset names -- yr.range() called in "the big for loop" instead of apply. The loop - exists anyway, and there's no need to keep yr.range() of all - series at the same time. -- rwca is no longer a data.frame, and doesn't have unnecessary colnames - -File: read.tridas.R -------------------- - -- Fixed a bug where a wrong number of derived series was reported in - summary output -- A performance optimization for the case where ids.from.title is FALSE, - ids.from.identifiers is TRUE (the defaults), and there are no identifiers - -File: series.rwl.plot.R ------------------------ - -- Uses complete argument names - -File: wavelet.plot.R --------------------- - -- Uses complete argument names -- gettext() is used in some default values - -File: wavelet.plot.Rd ---------------------- - -- Uses complete argument names -- Default values match the changes in wavelet.plot.R - -File: write.crn.R ------------------ - -- Uses complete argument names - -* CHANGES IN dplR VERSION 1.4.2 -* Ran through Mikko's changes. June 2, 2011. AGB -* Changes below by Mikko Korpela - -All .rda data files (change reported June 7, after release in CRAN) -------------------- - -- Data files were repackaged by R-Forge using a tight compression - level. This is done every time R-Forge builds the dplR package, but the - files are expected to stay identical if no changes are made to the - compression system. The new data files supposedly require R 2.10.0, but - this does not affect dplR which requires R >= 2.11.0 anyway. - -File: ccf.series.rwl.R ----------------------- - -- as.vector() is more intuitive than c() with one argument -- Cosmetic improvement - -File: ccf.series.rwl.Rd ------------------------ - -- bin.floor must be non-negative, not necessarily positive - -File: cms.R ------------ - -- Removed redundant c() -- Some values are stored for reuse - -File: corr.rwl.seg.R --------------------- - -- par(op) moved to on.exit() -- Odd and even segs are plotted with the same code, avoiding copy-paste -- Some values are stored for reuse -- Some unnecessary colnames are not set -- Cosmetic improvement - -File: corr.rwl.seg.Rd ---------------------- - -- bin.floor must be non-negative, not necessarily positive - -File: corr.series.seg.Rd ------------------------- - -- bin.floor must be non-negative, not necessarily positive - -File: crn.plot.R ----------------- - -- Default value of f is explicitly 0.5 - -File: crn.plot.Rd ------------------ - -- Clarified the default values of f and nyrs - -File: ffcsaps.R ---------------- - -- Cosmetic improvement - -File: i.detrend.series.R ------------------------- - -- A value is stored for reuse -- Cosmetic change - -File: qa.xdate.R ----------------- - -- bin.floor must be non-negative, not necessarily positive -- Checks that bin.floor is non-negative. - -File: rcompact.c ----------------- - -- Accepts comment lines in the beginning of the file -- Cosmetic changes (formatting of comments) -- UNPROTECT all PROTECTed structures at the same time - -File: rcs.R ------------ - -- Some values are stored for reuse - -File: read.compact.R --------------------- - -- Prints comments found in the file (if any) - -File: rwi.stats.R ------------------ - -- Within-tree signal is now computed correctly (thanks to Pierre M?rian) - -File: rwl.stats.R ------------------ - -- Removed redundant instances of c() -- Cosmetic improvement - -File: series.rwl.plot.Rd ------------------------- - -- bin.floor must be non-negative, not necessarily positive - -File: skel.plot.R ------------------ - -- Only makes as many viewports as needed -- Some values are stored for reuse -- Checks that length of input exceeds a minimum value -- Avoids warning from giving an empty vector to range() - -File: wavelet.plot.R --------------------- - -- Some lines previously in both branches of if-else now appear only once -- Avoids a duplicate call to unique() - -2011-05-26 Andy Bunn -* CHANGES IN dplR VERSION 1.4.1 -* All changes by Mikko Korpela - -File: DESCRIPTION ------------------ - -- Minimum R version is now 2.11.0 (previously not specified). Reason - behind the requirement: The encoding support added to read.tucson - brought out a bug in read.fwf. The bug exists in 2.10.1 but is fixed - in 2.11.0. -- Suggests foreach and iterators (used in some functions if installed) - -Files: bai.in.R, bai.in.Rd, bai.out.R, bai.out.Rd -------------------------------------------------- - -- Cosmetic improvement -- Also changed indentation of .R files to the recommended 4 spaces, as - in the other .R, .c and .h files edited in this patch set. - -File: ccf.series.rwl.R ----------------------- - -- || instead of | -- Optimized the order of expressions in a chain of the form - x_1 || ... || x_n (order did not matter when | was used) -- Removed an unused variable. -- Cosmetic improvement - -File: ccf.series.rwl.Rd ------------------------ - -- Cosmetic improvement - -File: chron.R -------------- - -- Removed redundant c() -- Default value of prefix is now "xxx". Previously the default value - was NULL, which was then converted to "xxx". -- Cosmetic improvement - -File: chron.Rd --------------- - -- Documents new (explicit) default value of prefix. -- Cosmetic improvement - -File: cms.R ------------ - -- Some added robustness against weird input -- Optimizations -- Cosmetic improvement - -File: cms.Rd ------------- - -- Note about the requirement that the years be increasing and - continuous - -File: combine.rwl.R -------------------- - -- Input handling was improved. -- Loops were eliminated from combinator() - -File: combine.rwl.Rd --------------------- - -- Note about requirements for input (also existed in previous - versions) -- Author of the patch mentioned - -File: corr.rwl.seg.R --------------------- - -- || instead of | -- Optimized the order of expressions in a chain of the form - x_1 || ... || x_n (order did not matter when | was used) -- Small optimizations -- Cosmetic improvement - -File: corr.series.seg.R ------------------------ - -- Cosmetic improvement - -File: crn.plot.R ----------------- - -- Cosmetic improvement - -File: detrend.R ---------------- - [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/dplr -r 718 From noreply at r-forge.r-project.org Sun Jan 12 02:31:43 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 12 Jan 2014 02:31:43 +0100 (CET) Subject: [Dplr-commits] r719 - / pkg/dplR pkg/dplR/man Message-ID: <20140112013143.E6CF41860EA@r-forge.r-project.org> Author: andybunn Date: 2014-01-12 02:31:43 +0100 (Sun, 12 Jan 2014) New Revision: 719 Modified: / pkg/dplR/ChangeLog pkg/dplR/man/tbrm.Rd Log: fixed tbrm and modified its example slightly. Property changes on: ___________________________________________________________________ Modified: svn:ignore - .Rproj.user .Rhistory .RData + .Rproj.user .Rhistory .RData dplr.Rproj Modified: pkg/dplR/ChangeLog =================================================================== --- pkg/dplR/ChangeLog 2014-01-11 06:29:53 UTC (rev 718) +++ pkg/dplR/ChangeLog 2014-01-12 01:31:43 UTC (rev 719) @@ -1,13 +1,47 @@ * CHANGES IN dplR VERSION 1.5.8 +File: tbrm.Rd +--------------- +- Improved (slightly) the trbm() examples. + + File: tbrm.R --------------- - Changed tbrm call to .C so that it doesn't break CRAN's anti-social policy. Email from - BDR details error but R CMD check --as-cran dplR_1.5.8.tar.gz - still fails. + BDR details error. + Begin quote from Ripley: + The error is in your function tbrm: + + > tbrm + function (x, C = 9) + { + y <- as.double(x[!is.na(x)]) + n <- as.integer(length(y)) + stopifnot(!is.na(n)) + .C(dplR.tbrm, + y, n, as.double(C), result = NaN, NAOK = TRUE, DUP = FALSE)$result + } + + That .C call changes its arguments: see the warnings in ?.C . In this + case it changes the binding of NaN. + + You could remove DUP = FALSE (these days it is not helping) or use + + > tbrm + function (x, C = 9) + { + y <- as.double(x[!is.na(x)]) + n <- as.integer(length(y)) + stopifnot(!is.na(n)) + .C(dplR.tbrm, y, n, as.double(C), result = double(1L), NAOK = TRUE, + DUP = FALSE)$result + } + End quote from Ripley + This change was made and R CMD check --as-cran passes fine. + File: DESCRIPTION - Added Jacob Cecile as a contributor Modified: pkg/dplR/man/tbrm.Rd =================================================================== --- pkg/dplR/man/tbrm.Rd 2014-01-11 06:29:53 UTC (rev 718) +++ pkg/dplR/man/tbrm.Rd 2014-01-12 01:31:43 UTC (rev 719) @@ -1,64 +1,68 @@ -\name{tbrm} -\alias{tbrm} -\title{ Calculate Tukey's Biweight Robust Mean } -\description{ - This calculates a robust average that is unaffected by outliers. -} -\usage{ -tbrm(x, C = 9) -} -\arguments{ - \item{x}{ a \code{numeric} vector } - \item{C}{ a constant. \code{\var{C}} is preassigned a value of 9 - according to the Cook reference below but other values are - possible. } -} -\details{ - This is a one step computation that follows the Affy whitepaper below, - see page 22. This function is called by \code{\link{chron}} to - calculate a robust mean. \code{\var{C}} determines the point at which - outliers are given a weight of 0 and therefore do not contribute to - the calculation of the mean. \code{\var{C} = 9} sets values roughly - +/-6 standard deviations to 0. \code{\var{C} = 6} is also used in - tree-ring chronology development. Cook and Kairiukstis (1990) have - further details. - - An exact summation algorithm (Shewchuk 1997) is used. When some - assumptions about the rounding of floating point numbers and - conservative compiler optimizations hold, summation error is - completely avoided. Whether the assumptions hold depends on the - platform, i.e. compiler and \acronym{CPU}. -} -\value{ - A \code{numeric} mean. -} -\references{ - - Statistical Algorithms Description Document, 2002, Affymetrix. - - Cook, E. R. and Kairiukstis, L. A. (1990) \emph{Methods of - Dendrochronology: Applications in the Environmental Sciences}. - Springer. \acronym{ISBN-13}: 978-0-7923-0586-6. - - Mosteller, F. and Tukey, J. W. (1977) \emph{Data Analysis and - Regression: a second course in statistics}. Addison-Wesley. - \acronym{ISBN-13}: 978-0-201-04854-4. - - Shewchuk, J. R. (1997) Adaptive Precision Floating-Point Arithmetic - and Fast Robust Geometric Predicates. \emph{Discrete and - Computational Geometry}, 18(3):305\enc{?}{--}363. Springer. - -} -\author{ Mikko Korpela } -\seealso{ \code{\link{chron}} } -\examples{tbrm(rnorm(100)) - -## Compare -data(co021) -co021.rwi <- detrend(co021, method = "ModNegExp") -crn1 <- apply(co021.rwi, 1, tbrm) -crn2 <- chron(co021.rwi) -cor(crn1, crn2[, 1]) -} -\keyword{ robust } -\keyword{ univar } +\name{tbrm} +\alias{tbrm} +\title{ Calculate Tukey's Biweight Robust Mean } +\description{ + This calculates a robust average that is unaffected by outliers. +} +\usage{ +tbrm(x, C = 9) +} +\arguments{ + \item{x}{ a \code{numeric} vector } + \item{C}{ a constant. \code{\var{C}} is preassigned a value of 9 + according to the Cook reference below but other values are + possible. } +} +\details{ + This is a one step computation that follows the Affy whitepaper below, + see page 22. This function is called by \code{\link{chron}} to + calculate a robust mean. \code{\var{C}} determines the point at which + outliers are given a weight of 0 and therefore do not contribute to + the calculation of the mean. \code{\var{C} = 9} sets values roughly + +/-6 standard deviations to 0. \code{\var{C} = 6} is also used in + tree-ring chronology development. Cook and Kairiukstis (1990) have + further details. + + An exact summation algorithm (Shewchuk 1997) is used. When some + assumptions about the rounding of floating point numbers and + conservative compiler optimizations hold, summation error is + completely avoided. Whether the assumptions hold depends on the + platform, i.e. compiler and \acronym{CPU}. +} +\value{ + A \code{numeric} mean. +} +\references{ + + Statistical Algorithms Description Document, 2002, Affymetrix. + + Cook, E. R. and Kairiukstis, L. A. (1990) \emph{Methods of + Dendrochronology: Applications in the Environmental Sciences}. + Springer. \acronym{ISBN-13}: 978-0-7923-0586-6. + + Mosteller, F. and Tukey, J. W. (1977) \emph{Data Analysis and + Regression: a second course in statistics}. Addison-Wesley. + \acronym{ISBN-13}: 978-0-201-04854-4. + + Shewchuk, J. R. (1997) Adaptive Precision Floating-Point Arithmetic + and Fast Robust Geometric Predicates. \emph{Discrete and + Computational Geometry}, 18(3):305\enc{?}{--}363. Springer. + +} +\author{ Mikko Korpela } +\seealso{ \code{\link{chron}} } +\examples{ + +foo <- rnorm(100) +tbrm(foo) +mean(foo) + +## Compare +data(co021) +co021.rwi <- detrend(co021, method = "ModNegExp") +crn1 <- apply(co021.rwi, 1, tbrm) +crn2 <- chron(co021.rwi) +cor(crn1, crn2[, 1]) +} +\keyword{ robust } +\keyword{ univar } From noreply at r-forge.r-project.org Mon Jan 13 10:36:33 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Mon, 13 Jan 2014 10:36:33 +0100 (CET) Subject: [Dplr-commits] r720 - in pkg/dplR: . R Message-ID: <20140113093633.ACEC91867F2@r-forge.r-project.org> Author: mvkorpel Date: 2014-01-13 10:36:33 +0100 (Mon, 13 Jan 2014) New Revision: 720 Modified: pkg/dplR/ChangeLog pkg/dplR/DESCRIPTION pkg/dplR/R/exactmean.R pkg/dplR/R/gini.coef.R pkg/dplR/R/sens1.R pkg/dplR/R/sens2.R Log: Fixed other instances of the same "binding of NaN changed" bug. Modified: pkg/dplR/ChangeLog =================================================================== --- pkg/dplR/ChangeLog 2014-01-12 01:31:43 UTC (rev 719) +++ pkg/dplR/ChangeLog 2014-01-13 09:36:33 UTC (rev 720) @@ -4,44 +4,17 @@ --------------- - Improved (slightly) the trbm() examples. +Files: exactmean.R, gini.coef.R, sens1.R, sens2.R, tbrm.R +--------------------------------------------------------- -File: tbrm.R ---------------- +- Changed calls to .C (where we use DUP = FALSE) so that the + binding of NaN will not change, fixing multiple instances of a bug + in dplR code revealed by changes in recent R development versions. + We were accidentally breaking CRAN's "malicious or anti-social" + policy. Thanks to Professor Brian D. Ripley for reporting. -- Changed tbrm call to .C so that it doesn't - break CRAN's anti-social policy. Email from - BDR details error. - Begin quote from Ripley: - The error is in your function tbrm: - - > tbrm - function (x, C = 9) - { - y <- as.double(x[!is.na(x)]) - n <- as.integer(length(y)) - stopifnot(!is.na(n)) - .C(dplR.tbrm, - y, n, as.double(C), result = NaN, NAOK = TRUE, DUP = FALSE)$result - } - - That .C call changes its arguments: see the warnings in ?.C . In this - case it changes the binding of NaN. - - You could remove DUP = FALSE (these days it is not helping) or use - - > tbrm - function (x, C = 9) - { - y <- as.double(x[!is.na(x)]) - n <- as.integer(length(y)) - stopifnot(!is.na(n)) - .C(dplR.tbrm, y, n, as.double(C), result = double(1L), NAOK = TRUE, - DUP = FALSE)$result - } - End quote from Ripley - This change was made and R CMD check --as-cran passes fine. + Now R CMD check --as-cran passes fine. - File: DESCRIPTION - Added Jacob Cecile as a contributor Modified: pkg/dplR/DESCRIPTION =================================================================== --- pkg/dplR/DESCRIPTION 2014-01-12 01:31:43 UTC (rev 719) +++ pkg/dplR/DESCRIPTION 2014-01-13 09:36:33 UTC (rev 720) @@ -3,7 +3,7 @@ Type: Package Title: Dendrochronology Program Library in R Version: 1.5.8 -Date: 2013-11-27 +Date: 2014-01-13 Authors at R: c(person("Andy", "Bunn", role = c("aut", "cph", "cre", "trl"), email = "andy.bunn at wwu.edu"), person("Mikko", "Korpela", role = c("aut", "trl")), person("Franco", "Biondi", Modified: pkg/dplR/R/exactmean.R =================================================================== --- pkg/dplR/R/exactmean.R 2014-01-12 01:31:43 UTC (rev 719) +++ pkg/dplR/R/exactmean.R 2014-01-13 09:36:33 UTC (rev 720) @@ -5,5 +5,5 @@ n <- as.integer(length(y)) stopifnot(!is.na(n)) .C(dplR.mean, - y, n, result=NaN, NAOK=TRUE, DUP=FALSE)$result + y, n, result=NaN*double(1L), NAOK=TRUE, DUP=FALSE)$result } Modified: pkg/dplR/R/gini.coef.R =================================================================== --- pkg/dplR/R/gini.coef.R 2014-01-12 01:31:43 UTC (rev 719) +++ pkg/dplR/R/gini.coef.R 2014-01-13 09:36:33 UTC (rev 720) @@ -4,5 +4,5 @@ n <- as.integer(length(y)) stopifnot(!is.na(n)) .C(dplR.gini, - y, n, result=NaN, NAOK=TRUE, DUP=FALSE)$result + y, n, result=double(1L), NAOK=TRUE, DUP=FALSE)$result } Modified: pkg/dplR/R/sens1.R =================================================================== --- pkg/dplR/R/sens1.R 2014-01-12 01:31:43 UTC (rev 719) +++ pkg/dplR/R/sens1.R 2014-01-13 09:36:33 UTC (rev 720) @@ -4,5 +4,5 @@ n <- as.integer(length(y)) stopifnot(!is.na(n)) .C(dplR.sens1, - y, n, result=NaN, NAOK=TRUE, DUP=FALSE)$result + y, n, result=NaN*double(1L), NAOK=TRUE, DUP=FALSE)$result } Modified: pkg/dplR/R/sens2.R =================================================================== --- pkg/dplR/R/sens2.R 2014-01-12 01:31:43 UTC (rev 719) +++ pkg/dplR/R/sens2.R 2014-01-13 09:36:33 UTC (rev 720) @@ -4,5 +4,5 @@ n <- as.integer(length(y)) stopifnot(!is.na(n)) .C(dplR.sens2, - y, n, result=NaN, NAOK=TRUE, DUP=FALSE)$result + y, n, result=NaN*double(1L), NAOK=TRUE, DUP=FALSE)$result } From noreply at r-forge.r-project.org Tue Jan 14 02:07:42 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 14 Jan 2014 02:07:42 +0100 (CET) Subject: [Dplr-commits] r721 - in pkg/dplR: R man Message-ID: <20140114010742.4CC8818686C@r-forge.r-project.org> Author: andybunn Date: 2014-01-14 02:07:41 +0100 (Tue, 14 Jan 2014) New Revision: 721 Modified: pkg/dplR/R/detrend.R pkg/dplR/R/detrend.series.R pkg/dplR/man/detrend.Rd pkg/dplR/man/detrend.series.Rd Log: default change made to detrend.series. Language to Rd files. Modified: pkg/dplR/R/detrend.R =================================================================== --- pkg/dplR/R/detrend.R 2014-01-13 09:36:33 UTC (rev 720) +++ pkg/dplR/R/detrend.R 2014-01-14 01:07:41 UTC (rev 721) @@ -1,69 +1,70 @@ -`detrend` <- - function(rwl, y.name = names(rwl), make.plot = FALSE, - method=c("Spline", "ModNegExp", "Mean"), - nyrs = NULL, f = 0.5, pos.slope = FALSE, - constrain.modnegexp = c("never", "when.fail", "always")) -{ - stopifnot(identical(make.plot, TRUE) || identical(make.plot, FALSE), - identical(pos.slope, FALSE) || identical(pos.slope, TRUE)) - known.methods <- c("Spline", "ModNegExp", "Mean") - constrain2 <- match.arg(constrain.modnegexp) - method2 <- match.arg(arg = method, - choices = known.methods, - several.ok = TRUE) - if(!is.data.frame(rwl)) - stop("'rwl' must be a data.frame") - rn <- row.names(rwl) - - if(!make.plot && - ("Spline" %in% method2 || "ModNegExp" %in% method2) && - !inherits(try(suppressWarnings(req.it <- - requireNamespace("iterators", - quietly=TRUE)), - silent = TRUE), - "try-error") && req.it && - !inherits(try(suppressWarnings(req.fe <- - requireNamespace("foreach", - quietly=TRUE)), - silent = TRUE), - "try-error") && req.fe){ - it.rwl <- iterators::iter(rwl, by = "col") - ## a way to get rid of "no visible binding" NOTE in R CMD check - rwl.i <- NULL - - exportFun <- c("detrend.series", "is.data.frame", - "row.names<-", "<-", "if") - - out <- foreach::"%dopar%"(foreach::foreach(rwl.i=it.rwl, - .export=exportFun), - { - fits <- detrend.series(rwl.i, make.plot=FALSE, - method=method2, - nyrs=nyrs, f=f, - pos.slope=pos.slope, - constrain.modnegexp= - constrain2) - if(is.data.frame(fits)) - row.names(fits) <- rn - fits - }) - } else{ - out <- list() - for(i in seq_len(ncol(rwl))){ - fits <- detrend.series(rwl[[i]], y.name=y.name[i], - make.plot=make.plot, - method=method2, nyrs=nyrs, f=f, - pos.slope=pos.slope, - constrain.modnegexp=constrain2) - if(is.data.frame(fits)) - row.names(fits) <- rn - out[[i]] <- fits - } - } - names(out) <- names(rwl) - if(length(method2) == 1){ - out <- data.frame(out, row.names = rn) - names(out) <- y.name - } - out -} +`detrend` <- + function(rwl, y.name = names(rwl), make.plot = FALSE, + method=c("Spline", "ModNegExp", "Mean"), + nyrs = NULL, f = 0.5, pos.slope = FALSE, + constrain.modnegexp = "never") + #constrain.modnegexp = c("never", "when.fail", "always")) +{ + stopifnot(identical(make.plot, TRUE) || identical(make.plot, FALSE), + identical(pos.slope, FALSE) || identical(pos.slope, TRUE)) + known.methods <- c("Spline", "ModNegExp", "Mean") + constrain2 <- match.arg(constrain.modnegexp) + method2 <- match.arg(arg = method, + choices = known.methods, + several.ok = TRUE) + if(!is.data.frame(rwl)) + stop("'rwl' must be a data.frame") + rn <- row.names(rwl) + + if(!make.plot && + ("Spline" %in% method2 || "ModNegExp" %in% method2) && + !inherits(try(suppressWarnings(req.it <- + requireNamespace("iterators", + quietly=TRUE)), + silent = TRUE), + "try-error") && req.it && + !inherits(try(suppressWarnings(req.fe <- + requireNamespace("foreach", + quietly=TRUE)), + silent = TRUE), + "try-error") && req.fe){ + it.rwl <- iterators::iter(rwl, by = "col") + ## a way to get rid of "no visible binding" NOTE in R CMD check + rwl.i <- NULL + + exportFun <- c("detrend.series", "is.data.frame", + "row.names<-", "<-", "if") + + out <- foreach::"%dopar%"(foreach::foreach(rwl.i=it.rwl, + .export=exportFun), + { + fits <- detrend.series(rwl.i, make.plot=FALSE, + method=method2, + nyrs=nyrs, f=f, + pos.slope=pos.slope, + constrain.modnegexp= + constrain2) + if(is.data.frame(fits)) + row.names(fits) <- rn + fits + }) + } else{ + out <- list() + for(i in seq_len(ncol(rwl))){ + fits <- detrend.series(rwl[[i]], y.name=y.name[i], + make.plot=make.plot, + method=method2, nyrs=nyrs, f=f, + pos.slope=pos.slope, + constrain.modnegexp=constrain2) + if(is.data.frame(fits)) + row.names(fits) <- rn + out[[i]] <- fits + } + } + names(out) <- names(rwl) + if(length(method2) == 1){ + out <- data.frame(out, row.names = rn) + names(out) <- y.name + } + out +} Modified: pkg/dplR/R/detrend.series.R =================================================================== --- pkg/dplR/R/detrend.series.R 2014-01-13 09:36:33 UTC (rev 720) +++ pkg/dplR/R/detrend.series.R 2014-01-14 01:07:41 UTC (rev 721) @@ -1,172 +1,172 @@ -`detrend.series` <- - function(y, y.name = "", make.plot = TRUE, - method = c("Spline", "ModNegExp", "Mean"), - nyrs = NULL, f = 0.5, pos.slope = FALSE, - constrain.modnegexp = c("never", "when.fail", "always")) -{ - stopifnot(identical(make.plot, TRUE) || identical(make.plot, FALSE), - identical(pos.slope, FALSE) || identical(pos.slope, TRUE)) - known.methods <- c("Spline", "ModNegExp", "Mean") - constrain2 <- match.arg(constrain.modnegexp) - method2 <- match.arg(arg = method, - choices = known.methods, - several.ok = TRUE) - ## Remove NA from the data (they will be reinserted later) - good.y <- which(!is.na(y)) - if(length(good.y) == 0) { - stop("all values are 'NA'") - } else if(any(diff(good.y) != 1)) { - stop("'NA's are not allowed in the middle of the series") - } - y2 <- y[good.y] - ## Recode any zero values to 0.001 - y2[y2 == 0] <- 0.001 - - resids <- list() - - if("ModNegExp" %in% method2){ - ## Nec or lm - nec.func <- function(Y, constrain) { - a <- mean(Y[seq_len(floor(length(Y) * 0.1))]) - b <- -0.01 - k <- mean(Y[floor(length(Y) * 0.9):length(Y)]) - nlsForm <- Y ~ a * exp(b * seq_along(Y)) + k - nlsStart <- list(a=a, b=b, k=k) - checked <- FALSE - if (constrain == "never") { - nec <- nls(formula = nlsForm, start = nlsStart) - } else if (constrain == "always") { - nec <- nls(formula = nlsForm, start = nlsStart, - lower = c(a=0, b=-Inf, k=0), - upper = c(a=Inf, b=0, k=Inf), - algorithm = "port") - } else { - nec <- nls(formula = nlsForm, start = nlsStart) - if(coef(nec)[2] >= 0) stop() - fits <- predict(nec) - if(fits[1] < fits[length(fits)]) stop() - if(fits[length(fits)] > 0) { - checked <- TRUE - } else { - nec <- nls(formula = nlsForm, start = nlsStart, - lower = c(a=0, b=-Inf, k=0), - upper = c(a=Inf, b=0, k=Inf), - algorithm = "port") - } - } - if (!checked) { - if(coef(nec)[2] >= 0) stop() - fits <- predict(nec) - if(fits[1] < fits[length(fits)]) stop() - if(fits[length(fits)] <= 0) stop() - } - fits - } - ModNegExp <- try(nec.func(y2, constrain2), silent=TRUE) - if(class(ModNegExp)=="try-error") { - ## Straight line via linear regression - tm <- cbind(1, seq_along(y2)) - lm1 <- lm.fit(tm, y2) - coefs <- lm1[["coefficients"]] - ModNegExp <- NULL - if (all(is.finite(coefs)) && (coefs[2] <= 0 || pos.slope)) { - ModNegExp <- drop(tm %*% coefs) - } - if (is.null(ModNegExp) || - ModNegExp[1] <= 0 || ModNegExp[length(y2)] <= 0) { - ModNegExp <- rep(mean(y2), length(y2)) - } - } - resids$ModNegExp <- y2 / ModNegExp - do.mne <- TRUE - } else { - do.mne <- FALSE - } - - if("Spline" %in% method2){ - ## Smoothing spline - ## "n-year spline" as the spline whose frequency response is - ## 50%, or 0.50, at a wavelength of 67%n years if nyrs and f - ## are NULL - if(is.null(nyrs)) - nyrs2 <- floor(length(y2) * 0.67) - else - nyrs2 <- nyrs - Spline <- ffcsaps(y=y2, x=seq_along(y2), nyrs=nyrs2, f=f) - if (any(Spline <= 0)) { - Spline <- rep(mean(y2), length(y2)) - } - resids$Spline <- y2 / Spline - do.spline <- TRUE - } else { - do.spline <- FALSE - } - - if("Mean" %in% method2){ - ## Fit a horiz line - Mean <- rep(mean(y2), length(y2)) - resids$Mean <- y2 / Mean - do.mean <- TRUE - } else { - do.mean <- FALSE - } - - resids <- data.frame(resids) - - if(make.plot){ - op <- par(no.readonly=TRUE) - on.exit(par(op)) - par(mar=c(2.5, 2.5, 2.5, 0.5) + 0.1, mgp=c(1.5, 0.5, 0)) - n.rows <- 1 + ncol(resids) - mat <- matrix(seq_len(n.rows), n.rows, 1) - layout(mat, - widths=rep(0.5, ncol(mat)), - heights=rep(1, nrow(mat))) - - plot(y2, type="l", ylab="mm", - xlab=gettext("Age (Yrs)", domain="R-dplR"), - main=gettextf("Raw Series %s", y.name, domain="R-dplR")) - if(do.spline) lines(Spline, col="green", lwd=2) - if(do.mne) lines(ModNegExp, col="red", lwd=2) - if(do.mean) lines(Mean, col="blue", lwd=2) - - if(do.spline){ - plot(resids$Spline, type="l", col="green", - main=gettext("Spline", domain="R-dplR"), - xlab=gettext("Age (Yrs)", domain="R-dplR"), - ylab=gettext("RWI", domain="R-dplR")) - abline(h=1) - } - - if(do.mne){ - plot(resids$ModNegExp, type="l", col="red", - main=gettext("Neg. Exp. Curve or Straight Line", - domain="R-dplR"), - xlab=gettext("Age (Yrs)", domain="R-dplR"), - ylab=gettext("RWI", domain="R-dplR")) - abline(h=1) - } - - if(do.mean){ - plot(resids$Mean, type="l", col="blue", - main=gettext("Horizontal Line (Mean)", domain="R-dplR"), - xlab=gettext("Age (Yrs)", domain="R-dplR"), - ylab=gettext("RWI", domain="R-dplR")) - abline(h=1) - } - } - - resids2 <- matrix(NA, ncol=ncol(resids), nrow=length(y)) - resids2 <- data.frame(resids2) - names(resids2) <- names(resids) - if(!is.null(names(y))) row.names(resids2) <- names(y) - resids2[good.y, ] <- resids - - ## Reorder columns of output to match the order of the argument - ## "method". - resids2 <- resids2[, method2] - ## Make sure names (years) are included if there is only one method - if(!is.data.frame(resids2)) names(resids2) <- names(y) - - resids2 -} +`detrend.series` <- + function(y, y.name = "", make.plot = TRUE, + method = c("Spline", "ModNegExp", "Mean"), + nyrs = NULL, f = 0.5, pos.slope = FALSE, + constrain.modnegexp = "never") + #constrain.modnegexp = c("never", "when.fail", "always")) +{ + stopifnot(identical(make.plot, TRUE) || identical(make.plot, FALSE), + identical(pos.slope, FALSE) || identical(pos.slope, TRUE)) + known.methods <- c("Spline", "ModNegExp", "Mean") + constrain2 <- match.arg(constrain.modnegexp) + method2 <- match.arg(arg = method, + choices = known.methods, + several.ok = TRUE) + ## Remove NA from the data (they will be reinserted later) + good.y <- which(!is.na(y)) + if(length(good.y) == 0) { + stop("all values are 'NA'") + } else if(any(diff(good.y) != 1)) { + stop("'NA's are not allowed in the middle of the series") + } + y2 <- y[good.y] + ## Recode any zero values to 0.001 + y2[y2 == 0] <- 0.001 + + resids <- list() + + if("ModNegExp" %in% method2){ + ## Nec or lm + nec.func <- function(Y, constrain) { + a <- mean(Y[seq_len(floor(length(Y) * 0.1))]) + b <- -0.01 + k <- mean(Y[floor(length(Y) * 0.9):length(Y)]) + nlsForm <- Y ~ a * exp(b * seq_along(Y)) + k + nlsStart <- list(a=a, b=b, k=k) + checked <- FALSE + if (constrain == "never") { + nec <- nls(formula = nlsForm, start = nlsStart) + } else if (constrain == "always") { + nec <- nls(formula = nlsForm, start = nlsStart, + lower = c(a=0, b=-Inf, k=0), + upper = c(a=Inf, b=0, k=Inf), + algorithm = "port") + } else { + nec <- nls(formula = nlsForm, start = nlsStart) + if(coef(nec)[2] >= 0) stop() + fits <- predict(nec) + if(fits[1] < fits[length(fits)]) stop() + if(fits[length(fits)] > 0) { + checked <- TRUE + } else { + nec <- nls(formula = nlsForm, start = nlsStart, + lower = c(a=0, b=-Inf, k=0), + upper = c(a=Inf, b=0, k=Inf), + algorithm = "port") + } + } + if (!checked) { + if(coef(nec)[2] >= 0) stop() + fits <- predict(nec) + if(fits[1] < fits[length(fits)]) stop() + if(fits[length(fits)] <= 0) stop() + } + fits + } + ModNegExp <- try(nec.func(y2, constrain2), silent=TRUE) + if(class(ModNegExp)=="try-error") { + ## Straight line via linear regression + tm <- cbind(1, seq_along(y2)) + lm1 <- lm.fit(tm, y2) + coefs <- lm1[["coefficients"]] + ModNegExp <- NULL + if (all(is.finite(coefs)) && (coefs[2] <= 0 || pos.slope)) { + ModNegExp <- drop(tm %*% coefs) + } + if (is.null(ModNegExp) || + ModNegExp[1] <= 0 || ModNegExp[length(y2)] <= 0) { + ModNegExp <- rep(mean(y2), length(y2)) + } + } + resids$ModNegExp <- y2 / ModNegExp + do.mne <- TRUE + } else { + do.mne <- FALSE + } + + if("Spline" %in% method2){ + ## Smoothing spline + ## "n-year spline" as the spline whose frequency response is + ## 50%, or 0.50, at a wavelength of 67%n years if nyrs and f + ## are NULL + if(is.null(nyrs)) + nyrs2 <- floor(length(y2) * 0.67) + else + nyrs2 <- nyrs + Spline <- ffcsaps(y=y2, x=seq_along(y2), nyrs=nyrs2, f=f) + if (any(Spline <= 0)) { + Spline <- rep(mean(y2), length(y2)) + } + resids$Spline <- y2 / Spline + do.spline <- TRUE + } else { + do.spline <- FALSE + } + + if("Mean" %in% method2){ + ## Fit a horiz line + Mean <- rep(mean(y2), length(y2)) + resids$Mean <- y2 / Mean + do.mean <- TRUE + } else { + do.mean <- FALSE + } + + resids <- data.frame(resids) + + if(make.plot){ + op <- par(no.readonly=TRUE) + on.exit(par(op)) + par(mar=c(2.5, 2.5, 2.5, 0.5) + 0.1, mgp=c(1.5, 0.5, 0)) + n.rows <- 1 + ncol(resids) + mat <- matrix(seq_len(n.rows), n.rows, 1) + layout(mat, + widths=rep(0.5, ncol(mat)), + heights=rep(1, nrow(mat))) + + plot(y2, type="l", ylab="mm", + xlab=gettext("Age (Yrs)", domain="R-dplR"), + main=gettextf("Raw Series %s", y.name, domain="R-dplR")) + if(do.spline) lines(Spline, col="green", lwd=2) + if(do.mne) lines(ModNegExp, col="red", lwd=2) + if(do.mean) lines(Mean, col="blue", lwd=2) + + if(do.spline){ + plot(resids$Spline, type="l", col="green", + main=gettext("Spline", domain="R-dplR"), + xlab=gettext("Age (Yrs)", domain="R-dplR"), + ylab=gettext("RWI", domain="R-dplR")) + abline(h=1) + } + + if(do.mne){ + plot(resids$ModNegExp, type="l", col="red", + main=gettext("Neg. Exp. Curve or Straight Line", + domain="R-dplR"), + xlab=gettext("Age (Yrs)", domain="R-dplR"), + ylab=gettext("RWI", domain="R-dplR")) + abline(h=1) + } + + if(do.mean){ + plot(resids$Mean, type="l", col="blue", + main=gettext("Horizontal Line (Mean)", domain="R-dplR"), + xlab=gettext("Age (Yrs)", domain="R-dplR"), + ylab=gettext("RWI", domain="R-dplR")) + abline(h=1) + } + } + + resids2 <- matrix(NA, ncol=ncol(resids), nrow=length(y)) + resids2 <- data.frame(resids2) + names(resids2) <- names(resids) + if(!is.null(names(y))) row.names(resids2) <- names(y) + resids2[good.y, ] <- resids + + ## Reorder columns of output to match the order of the argument + ## "method". + resids2 <- resids2[, method2] + ## Make sure names (years) are included if there is only one method + if(!is.data.frame(resids2)) names(resids2) <- names(y) + resids2 +} Modified: pkg/dplR/man/detrend.Rd =================================================================== --- pkg/dplR/man/detrend.Rd 2014-01-13 09:36:33 UTC (rev 720) +++ pkg/dplR/man/detrend.Rd 2014-01-14 01:07:41 UTC (rev 721) @@ -1,82 +1,83 @@ -\name{detrend} -\alias{detrend} -\title{ Detrend Multiple Ring-Width Series Simultaneously } -\description{ - This is a wrapper for \code{\link{detrend.series}} to detrend many - ring-width series at once. -} -\usage{ -detrend(rwl, y.name = names(rwl), make.plot = FALSE, - method = c("Spline", "ModNegExp", "Mean"), nyrs = NULL, - f = 0.5, pos.slope = FALSE, - constrain.modnegexp = c("never", "when.fail", "always")) -} -\arguments{ - - \item{rwl}{ a \code{data.frame} with series as columns and years as - rows such as that produced by \code{\link{read.rwl}} } - - \item{y.name}{ a \code{character} vector of - \code{length(ncol(\var{rwl}))} that gives the \acronym{ID} of each - series. Defaults to the column names of \code{\var{rwl}}. } - - \item{make.plot}{ a \code{logical} flag. Makes plots of the raw data - and detrended data if \code{TRUE}. See details below. } - - \item{method}{ a \code{character} vector to determine the detrending - methods. See details below. Possible values are all subsets of - \code{c("Spline", "ModNegExp", "Mean")}. Defaults to using all the - available methods.} - - \item{nyrs}{ a number giving the rigidity of the smoothing spline, - defaults to 0.67 of series length if \code{\var{nyrs}} is - \code{NULL}. } - - \item{f}{ a number between 0 and 1 giving the frequency response or - wavelength cutoff. Defaults to 0.5. } - - \item{pos.slope}{ a \code{logical} flag. Will allow for a positive - slope to be used in method \code{"ModNegExp"}. If \code{FALSE} the - line will be horizontal. } - - \item{constrain.modnegexp}{ a \code{character} string which controls - the constraints of the \code{"ModNegExp"} model. } - -} -\details{ - See \code{\link{detrend.series}} for details on detrending - methods. Setting \code{\var{make.plot} = TRUE} will cause plots of - each series to be produced. These could be saved using - \code{\link{Devices}} if desired. -} -\value{ - If one detrending method is used, a \code{data.frame} containing the - dimensionless detrended ring widths with column names, row names and - dimensions of \code{\var{rwl}}. If more methods are used, a list with - \code{ncol(\var{rwl})} elements each containing a \code{data.frame} - with the detrended ring widths in each column. -} -\note{ - This function uses the \code{\link[foreach]{foreach}} looping - construct with the \code{\link[foreach:foreach]{\%dopar\%}} operator. - For parallel computing and a potential speedup, a parallel backend - must be registered before running the function. -} -\author{ Andy Bunn. Improved by Mikko Korpela. } -\seealso{ \code{\link{detrend.series}} } -\examples{data(ca533) -## Detrend using modified expontential decay. Returns a data.frame -ca533.rwi <- detrend(rwl = ca533, method = "ModNegExp") - -\dontrun{ -library(grDevices) -## Detrend using all methods. Returns a list -ca533.rwi <- detrend(rwl = ca533) -## Save a pdf of all series -pdf("foo.pdf") -ca533.rwi <- detrend(rwl = ca533, method = c("Spline", "ModNegExp"), - make.plot = TRUE) -dev.off() -} -} -\keyword{ manip } +\name{detrend} +\alias{detrend} +\title{ Detrend Multiple Ring-Width Series Simultaneously } +\description{ + This is a wrapper for \code{\link{detrend.series}} to detrend many + ring-width series at once. +} +\usage{ +detrend(rwl, y.name = names(rwl), make.plot = FALSE, + method = c("Spline", "ModNegExp", "Mean"), nyrs = NULL, + f = 0.5, pos.slope = FALSE, + constrain.modnegexp = c("never", "when.fail", "always")) +} +\arguments{ + + \item{rwl}{ a \code{data.frame} with series as columns and years as + rows such as that produced by \code{\link{read.rwl}} } + + \item{y.name}{ a \code{character} vector of + \code{length(ncol(\var{rwl}))} that gives the \acronym{ID} of each + series. Defaults to the column names of \code{\var{rwl}}. } + + \item{make.plot}{ a \code{logical} flag. Makes plots of the raw data + and detrended data if \code{TRUE}. See details below. } + + \item{method}{ a \code{character} vector to determine the detrending + methods. See details below. Possible values are all subsets of + \code{c("Spline", "ModNegExp", "Mean")}. Defaults to using all the + available methods.} + + \item{nyrs}{ a number giving the rigidity of the smoothing spline, + defaults to 0.67 of series length if \code{\var{nyrs}} is + \code{NULL}. } + + \item{f}{ a number between 0 and 1 giving the frequency response or + wavelength cutoff. Defaults to 0.5. } + + \item{pos.slope}{ a \code{logical} flag. Will allow for a positive + slope to be used in method \code{"ModNegExp"}. If \code{FALSE} the + line will be horizontal. } + + \item{constrain.modnegexp}{ a \code{character} string which controls + the constraints of the \code{"ModNegExp"} model. See + \code{\link{detrend.series}} for further details. } + +} +\details{ + See \code{\link{detrend.series}} for details on detrending + methods. Setting \code{\var{make.plot} = TRUE} will cause plots of + each series to be produced. These could be saved using + \code{\link{Devices}} if desired. +} +\value{ + If one detrending method is used, a \code{data.frame} containing the + dimensionless detrended ring widths with column names, row names and + dimensions of \code{\var{rwl}}. If more methods are used, a list with + \code{ncol(\var{rwl})} elements each containing a \code{data.frame} + with the detrended ring widths in each column. +} +\note{ + This function uses the \code{\link[foreach]{foreach}} looping + construct with the \code{\link[foreach:foreach]{\%dopar\%}} operator. + For parallel computing and a potential speedup, a parallel backend + must be registered before running the function. +} +\author{ Andy Bunn. Improved by Mikko Korpela. } +\seealso{ \code{\link{detrend.series}} } +\examples{data(ca533) +## Detrend using modified expontential decay. Returns a data.frame +ca533.rwi <- detrend(rwl = ca533, method = "ModNegExp") + +\dontrun{ +library(grDevices) +## Detrend using all methods. Returns a list +ca533.rwi <- detrend(rwl = ca533) +## Save a pdf of all series +pdf("foo.pdf") +ca533.rwi <- detrend(rwl = ca533, method = c("Spline", "ModNegExp"), + make.plot = TRUE) +dev.off() +} +} +\keyword{ manip } Modified: pkg/dplR/man/detrend.series.Rd =================================================================== --- pkg/dplR/man/detrend.series.Rd 2014-01-13 09:36:33 UTC (rev 720) +++ pkg/dplR/man/detrend.series.Rd 2014-01-14 01:07:41 UTC (rev 721) @@ -1,124 +1,128 @@ -\name{detrend.series} -\alias{detrend.series} -\title{ Detrend a Ring-Width Series } -\description{ - Detrend a tree-ring series by one of two methods, a smoothing spline or - a statistical model. The series and fits are plotted by default. -} -\usage{ -detrend.series(y, y.name = "", make.plot = TRUE, - method = c("Spline", "ModNegExp", "Mean"), - nyrs = NULL, f = 0.5, pos.slope = FALSE, - constrain.modnegexp = c("never", "when.fail", "always")) -} -\arguments{ - - \item{y}{ a \code{numeric} vector. Usually a tree-ring series. } - - \item{y.name}{ an optional \code{character} vector to name the series - for plotting purposes. } - - \item{make.plot}{ a \code{logical} flag. Makes plots of the raw data - and detrended data if \code{TRUE}. } - - \item{method}{ a \code{character} vector to determine the detrending - methods. See details below. Possible values are all subsets of - \code{c("Spline", "ModNegExp", "Mean")}. Defaults to using all the - available methods.} - - \item{nyrs}{ a number giving the rigidity of the smoothing spline, - defaults to 0.67 of series length if \code{\var{nyrs}} is - \code{NULL}. } - - \item{f}{ a number between 0 and 1 giving the frequency response or - wavelength cutoff. Defaults to 0.5. } - - \item{pos.slope}{ a \code{logical} flag. Will allow for a positive - slope to be used in method \code{"ModNegExp"}. If \code{FALSE} the - line will be horizontal. } - - \item{constrain.modnegexp}{ a \code{character} string which controls - the constraints of the \code{"ModNegExp"} model. The value is an - answer to the question: When should the parameters of the modified - negative exponential function be constrained? The options are - \code{"never"}: do not constrain (the default), \code{"when.fail"}: - only compute the constrained solution if the unconstrained fit - contains other than positive values, and \code{"always"}: return the - constrained solution, even if the unconstrained one would have been - valid. See \sQuote{Details}. } - -} -\details{ - This detrends and standardizes a tree-ring series. The detrending is - the estimation and removal of the tree's natural biological growth - trend. The standardization is done by dividing each series by the - growth trend to produce units in the dimensionless ring-width index - (\acronym{RWI}). There are currently three methods available for - detrending although more are certainly possible. The methods - implemented are a smoothing spline via \code{\link{ffcsaps}} - (\code{\var{method} = "Spline"}), a modified negative exponential - curve (\code{\var{method} = "ModNegExp"}), or a simple horizontal line - (\code{\var{method} = "Mean"}). - - The \code{"Spline"} approach uses an spline where the frequency - response is 0.50 at a wavelength of 0.67 * \dQuote{series length in - years}, unless specified differently using \code{\var{nyrs}} and - \code{\var{f}} in the function \code{\link{ffcsaps}}. This attempts - to remove the low frequency variability that is due to biological or - stand effects. - - The \code{"ModNegExp"} approach attempts to fit a classic nonlinear - model of biological growth of the form \eqn{f(t) = a e^{b t} + k}{f(t) - = a exp(b t) + k}, where the argument of the function is time, using - \code{\link{nls}}. See Fritts (2001) for details about the - parameters. Option \code{\var{constrain.modnegexp}} gives a - possibility to constrain the parameters of the modified negative - exponential function. If the constraints are enabled, the nonlinear - optimization algorithm is instructed to keep the parameters in the - following ranges: \eqn{a \ge 0}{a >= 0}, \eqn{b \le 0}{b <= 0} and - \eqn{k \ge 0}{k >= 0}. If a suitable nonlinear model cannot be fit - (function is non-decreasing or some values are not positive) then a - linear model is fit. That linear model can have a positive slope - unless \code{\var{pos.slope}} is \code{FALSE} in which case method - \code{"Mean"} is used. - - The \code{"Mean"} approach fits a horizontal line using the mean of - the series. This method is the fallback solution in cases where the - \code{"Spline"} or the linear fit (also a fallback solution itself) - contains zeros or negative values, which would lead to invalid - ring-width indices. - - These methods are chosen because they are commonly used in - dendrochronology. It is, of course, up to the user to determine the - best detrending method for their data. See the references below for - further details on detrending. -} -\value{ - If several methods are used, returns a \code{data.frame} containing - the detrended series (\code{\var{y}}) according to the methods - used. If only one method is selected, returns a vector. -} -\references{ - Cook, E. R. and Kairiukstis, L. A. (1990) \emph{Methods of - Dendrochronology: Applications in the Environmental Sciences}. - Springer. \acronym{ISBN-13}: 978-0-7923-0586-6. - - Fritts, H. C. (2001) \emph{Tree Rings and Climate}. - Blackburn. \acronym{ISBN-13}: 978-1-930665-39-2. -} -\author{ Andy Bunn. Patched and improved by Mikko Korpela. A bug fix - related to negative output values is based on work by Jacob Cecile. } -\seealso{ \code{\link{detrend}} } -\examples{library(stats) -## Using a plausible representation of a tree-ring series -gt <- 0.5 * exp (-0.05 * 1:200) + 0.2 -noise <- c(arima.sim(model = list(ar = 0.7), n = 200, mean = 1, sd = 0.5)) -series <- gt * noise -series.rwi <- detrend.series(y = series, y.name = "Foo") -## Use series CAM011 from the Campito dataset -data(ca533) -series <- ca533[, "CAM011"] -names(series) <- rownames(ca533) -series.rwi <- detrend.series(y = series, y.name = "CAM011") -} -\keyword{ manip } +\name{detrend.series} +\alias{detrend.series} +\title{ Detrend a Ring-Width Series } +\description{ + Detrend a tree-ring series by one of two methods, a smoothing spline or + a statistical model. The series and fits are plotted by default. +} +\usage{ +detrend.series(y, y.name = "", make.plot = TRUE, + method = c("Spline", "ModNegExp", "Mean"), + nyrs = NULL, f = 0.5, pos.slope = FALSE, + constrain.modnegexp = c("never", "when.fail", "always")) +} +\arguments{ + + \item{y}{ a \code{numeric} vector. Usually a tree-ring series. } + + \item{y.name}{ an optional \code{character} vector to name the series + for plotting purposes. } + + \item{make.plot}{ a \code{logical} flag. Makes plots of the raw data + and detrended data if \code{TRUE}. } + + \item{method}{ a \code{character} vector to determine the detrending + methods. See details below. Possible values are all subsets of + \code{c("Spline", "ModNegExp", "Mean")}. Defaults to using all the + available methods.} + + \item{nyrs}{ a number giving the rigidity of the smoothing spline, + defaults to 0.67 of series length if \code{\var{nyrs}} is + \code{NULL}. } + [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/dplr -r 721 From noreply at r-forge.r-project.org Tue Jan 14 02:19:08 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 14 Jan 2014 02:19:08 +0100 (CET) Subject: [Dplr-commits] r722 - pkg/dplR/R Message-ID: <20140114011908.5ED5118628E@r-forge.r-project.org> Author: andybunn Date: 2014-01-14 02:19:07 +0100 (Tue, 14 Jan 2014) New Revision: 722 Modified: pkg/dplR/R/detrend.series.R Log: small note in detrend.series.R Modified: pkg/dplR/R/detrend.series.R =================================================================== --- pkg/dplR/R/detrend.series.R 2014-01-14 01:07:41 UTC (rev 721) +++ pkg/dplR/R/detrend.series.R 2014-01-14 01:19:07 UTC (rev 722) @@ -61,9 +61,11 @@ if(fits[1] < fits[length(fits)]) stop() if(fits[length(fits)] <= 0) stop() } + # put in a check on fits here and warn if negative? fits } ModNegExp <- try(nec.func(y2, constrain2), silent=TRUE) + if(class(ModNegExp)=="try-error") { ## Straight line via linear regression tm <- cbind(1, seq_along(y2)) From noreply at r-forge.r-project.org Tue Jan 14 09:27:06 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 14 Jan 2014 09:27:06 +0100 (CET) Subject: [Dplr-commits] r723 - in pkg/dplR: . R Message-ID: <20140114082706.41E5A186851@r-forge.r-project.org> Author: mvkorpel Date: 2014-01-14 09:27:05 +0100 (Tue, 14 Jan 2014) New Revision: 723 Modified: pkg/dplR/DESCRIPTION pkg/dplR/R/detrend.R pkg/dplR/R/detrend.series.R Log: Reverted changes to default of constrain.modnegexp argument made in r721. Reasoning: match.arg(foo) checks that the user gives a valid value for foo (must expand to or match one of the options) and returns the first character string from the default of foo if the user gives no value. So, what looks like a multi-string default becomes one string. Modified: pkg/dplR/DESCRIPTION =================================================================== --- pkg/dplR/DESCRIPTION 2014-01-14 01:19:07 UTC (rev 722) +++ pkg/dplR/DESCRIPTION 2014-01-14 08:27:05 UTC (rev 723) @@ -3,7 +3,7 @@ Type: Package Title: Dendrochronology Program Library in R Version: 1.5.8 -Date: 2014-01-13 +Date: 2014-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", Modified: pkg/dplR/R/detrend.R =================================================================== --- pkg/dplR/R/detrend.R 2014-01-14 01:19:07 UTC (rev 722) +++ pkg/dplR/R/detrend.R 2014-01-14 08:27:05 UTC (rev 723) @@ -2,8 +2,7 @@ function(rwl, y.name = names(rwl), make.plot = FALSE, method=c("Spline", "ModNegExp", "Mean"), nyrs = NULL, f = 0.5, pos.slope = FALSE, - constrain.modnegexp = "never") - #constrain.modnegexp = c("never", "when.fail", "always")) + constrain.modnegexp = c("never", "when.fail", "always")) { stopifnot(identical(make.plot, TRUE) || identical(make.plot, FALSE), identical(pos.slope, FALSE) || identical(pos.slope, TRUE)) Modified: pkg/dplR/R/detrend.series.R =================================================================== --- pkg/dplR/R/detrend.series.R 2014-01-14 01:19:07 UTC (rev 722) +++ pkg/dplR/R/detrend.series.R 2014-01-14 08:27:05 UTC (rev 723) @@ -2,8 +2,7 @@ function(y, y.name = "", make.plot = TRUE, method = c("Spline", "ModNegExp", "Mean"), nyrs = NULL, f = 0.5, pos.slope = FALSE, - constrain.modnegexp = "never") - #constrain.modnegexp = c("never", "when.fail", "always")) + constrain.modnegexp = c("never", "when.fail", "always")) { stopifnot(identical(make.plot, TRUE) || identical(make.plot, FALSE), identical(pos.slope, FALSE) || identical(pos.slope, TRUE)) @@ -61,11 +60,11 @@ if(fits[1] < fits[length(fits)]) stop() if(fits[length(fits)] <= 0) stop() } - # put in a check on fits here and warn if negative? + # put in a check on fits here and warn if negative? fits } ModNegExp <- try(nec.func(y2, constrain2), silent=TRUE) - + if(class(ModNegExp)=="try-error") { ## Straight line via linear regression tm <- cbind(1, seq_along(y2)) From noreply at r-forge.r-project.org Tue Jan 14 17:12:32 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 14 Jan 2014 17:12:32 +0100 (CET) Subject: [Dplr-commits] r724 - in pkg/dplR: . R Message-ID: <20140114161232.EAA0D183ACF@r-forge.r-project.org> Author: mvkorpel Date: 2014-01-14 17:12:32 +0100 (Tue, 14 Jan 2014) New Revision: 724 Modified: pkg/dplR/ChangeLog pkg/dplR/R/detrend.series.R Log: In detrend.series.R: - Warn if fit is not all positive (backup methods will be used) - Use simpler but equivalent rules for checking validity of ModNegExp fit - Small optimizations (rep.int; save and reuse length of input) Modified: pkg/dplR/ChangeLog =================================================================== --- pkg/dplR/ChangeLog 2014-01-14 08:27:05 UTC (rev 723) +++ pkg/dplR/ChangeLog 2014-01-14 16:12:32 UTC (rev 724) @@ -33,6 +33,9 @@ - A new argument: constrain.modnegexp. It is now possible to constrain the modified negative exponential function to non-negative values at infinity. +- Warn if fit is not all positive (backup methods will be used) +- Use simpler but equivalent rules for checking validity of ModNegExp fit +- Small optimizations (rep.int; save and reuse length of input) File: redfit.R -------------- Modified: pkg/dplR/R/detrend.series.R =================================================================== --- pkg/dplR/R/detrend.series.R 2014-01-14 08:27:05 UTC (rev 723) +++ pkg/dplR/R/detrend.series.R 2014-01-14 16:12:32 UTC (rev 724) @@ -19,6 +19,7 @@ stop("'NA's are not allowed in the middle of the series") } y2 <- y[good.y] + nY2 <- length(y2) ## Recode any zero values to 0.001 y2[y2 == 0] <- 0.001 @@ -27,12 +28,14 @@ if("ModNegExp" %in% method2){ ## Nec or lm nec.func <- function(Y, constrain) { - a <- mean(Y[seq_len(floor(length(Y) * 0.1))]) + nY <- length(Y) + a <- mean(Y[seq_len(max(1, floor(nY * 0.1)))]) b <- -0.01 - k <- mean(Y[floor(length(Y) * 0.9):length(Y)]) - nlsForm <- Y ~ a * exp(b * seq_along(Y)) + k + k <- mean(Y[floor(nY * 0.9):nY]) + nlsForm <- Y ~ a * exp(b * seq_len(nY)) + k nlsStart <- list(a=a, b=b, k=k) checked <- FALSE + ## Note: nls() may signal an error if (constrain == "never") { nec <- nls(formula = nlsForm, start = nlsStart) } else if (constrain == "always") { @@ -42,10 +45,12 @@ algorithm = "port") } else { nec <- nls(formula = nlsForm, start = nlsStart) - if(coef(nec)[2] >= 0) stop() + coefs <- coef(nec) + if (coefs[1] <= 0 || coefs[2] >= 0) { + stop() + } fits <- predict(nec) - if(fits[1] < fits[length(fits)]) stop() - if(fits[length(fits)] > 0) { + if (fits[nY] > 0) { checked <- TRUE } else { nec <- nls(formula = nlsForm, start = nlsStart, @@ -55,28 +60,43 @@ } } if (!checked) { - if(coef(nec)[2] >= 0) stop() + coefs <- coef(nec) + if (coefs[1] <= 0 || coefs[2] >= 0) { + stop() + } fits <- predict(nec) - if(fits[1] < fits[length(fits)]) stop() - if(fits[length(fits)] <= 0) stop() + if (fits[nY] <= 0) { + ## This error is a special case that needs to be + ## detected (if only for giving a warning). Any + ## smarter way to implement this? + return(NULL) + } } - # put in a check on fits here and warn if negative? fits } ModNegExp <- try(nec.func(y2, constrain2), silent=TRUE) + mneNotPositive <- is.null(ModNegExp) - if(class(ModNegExp)=="try-error") { + if (mneNotPositive || class(ModNegExp) == "try-error") { ## Straight line via linear regression - tm <- cbind(1, seq_along(y2)) + if (mneNotPositive) { + warning("ModNegExp fit is not all positive, see constrain.modnegexp") + } + tm <- cbind(1, seq_len(nY2)) lm1 <- lm.fit(tm, y2) coefs <- lm1[["coefficients"]] - ModNegExp <- NULL if (all(is.finite(coefs)) && (coefs[2] <= 0 || pos.slope)) { ModNegExp <- drop(tm %*% coefs) + useMean <- !isTRUE(ModNegExp[1] > 0 && + ModNegExp[nY2] > 0) + if (useMean) { + warning("Linear fit (backup of ModNegExp) is not all positive") + } + } else { + useMean <- TRUE } - if (is.null(ModNegExp) || - ModNegExp[1] <= 0 || ModNegExp[length(y2)] <= 0) { - ModNegExp <- rep(mean(y2), length(y2)) + if (useMean) { + ModNegExp <- rep.int(mean(y2), nY2) } } resids$ModNegExp <- y2 / ModNegExp @@ -91,12 +111,13 @@ ## 50%, or 0.50, at a wavelength of 67%n years if nyrs and f ## are NULL if(is.null(nyrs)) - nyrs2 <- floor(length(y2) * 0.67) + nyrs2 <- floor(nY2 * 0.67) else nyrs2 <- nyrs - Spline <- ffcsaps(y=y2, x=seq_along(y2), nyrs=nyrs2, f=f) + Spline <- ffcsaps(y=y2, x=seq_len(nY2), nyrs=nyrs2, f=f) if (any(Spline <= 0)) { - Spline <- rep(mean(y2), length(y2)) + warning("Spline fit is not all positive") + Spline <- rep.int(mean(y2), nY2) } resids$Spline <- y2 / Spline do.spline <- TRUE @@ -106,7 +127,7 @@ if("Mean" %in% method2){ ## Fit a horiz line - Mean <- rep(mean(y2), length(y2)) + Mean <- rep.int(mean(y2), nY2) resids$Mean <- y2 / Mean do.mean <- TRUE } else { @@ -122,8 +143,8 @@ n.rows <- 1 + ncol(resids) mat <- matrix(seq_len(n.rows), n.rows, 1) layout(mat, - widths=rep(0.5, ncol(mat)), - heights=rep(1, nrow(mat))) + widths=rep.int(0.5, ncol(mat)), + heights=rep.int(1, nrow(mat))) plot(y2, type="l", ylab="mm", xlab=gettext("Age (Yrs)", domain="R-dplR"), From noreply at r-forge.r-project.org Tue Jan 14 19:05:31 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 14 Jan 2014 19:05:31 +0100 (CET) Subject: [Dplr-commits] r725 - in pkg/dplR: R man Message-ID: <20140114180531.1D03D1862A0@r-forge.r-project.org> Author: andybunn Date: 2014-01-14 19:05:30 +0100 (Tue, 14 Jan 2014) New Revision: 725 Modified: pkg/dplR/R/detrend.series.R pkg/dplR/man/detrend.series.Rd Log: Small wording changes made to warning message on constrain.modnegexp and in help file of detrend.series(). Modified: pkg/dplR/R/detrend.series.R =================================================================== --- pkg/dplR/R/detrend.series.R 2014-01-14 16:12:32 UTC (rev 724) +++ pkg/dplR/R/detrend.series.R 2014-01-14 18:05:30 UTC (rev 725) @@ -80,7 +80,7 @@ if (mneNotPositive || class(ModNegExp) == "try-error") { ## Straight line via linear regression if (mneNotPositive) { - warning("ModNegExp fit is not all positive, see constrain.modnegexp") + warning("Fits from ModNegExp are not all positive, see constrain.modnegexp argument in detrend.series") } tm <- cbind(1, seq_len(nY2)) lm1 <- lm.fit(tm, y2) Modified: pkg/dplR/man/detrend.series.Rd =================================================================== --- pkg/dplR/man/detrend.series.Rd 2014-01-14 16:12:32 UTC (rev 724) +++ pkg/dplR/man/detrend.series.Rd 2014-01-14 18:05:30 UTC (rev 725) @@ -93,9 +93,13 @@ ring-width indices. These methods are chosen because they are commonly used in - dendrochronology. It is, of course, up to the user to determine the - best detrending method for their data. See the references below for - further details on detrending. + dendrochronology. There is a rich literature on detrending + and many researchers are particularly skeptical of the use of the + classic nonlinear model of biological growth (\eqn{f(t) = a e^{b t} + k}{f(t) + = a exp(b t) + k}) for detrending. It is, of course, up to the + user to determine the best detrending method for their data. + + See the references below for further details on detrending. } \value{ If several methods are used, returns a \code{data.frame} containing From noreply at r-forge.r-project.org Wed Jan 15 12:16:30 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 15 Jan 2014 12:16:30 +0100 (CET) Subject: [Dplr-commits] r726 - in pkg/dplR: . src Message-ID: <20140115111631.24FC0185B1A@r-forge.r-project.org> Author: mvkorpel Date: 2014-01-15 12:15:43 +0100 (Wed, 15 Jan 2014) New Revision: 726 Modified: pkg/dplR/ChangeLog pkg/dplR/DESCRIPTION pkg/dplR/src/redfit.c Log: In redfit.c: Avoid errors in case of redefined cbind() or length() Modified: pkg/dplR/ChangeLog =================================================================== --- pkg/dplR/ChangeLog 2014-01-14 18:05:30 UTC (rev 725) +++ pkg/dplR/ChangeLog 2014-01-15 11:15:43 UTC (rev 726) @@ -37,6 +37,12 @@ - Use simpler but equivalent rules for checking validity of ModNegExp fit - Small optimizations (rep.int; save and reuse length of input) +File: redfit.c +-------------- + +- Avoid possibly buggy behavior in the unlikely case that cbind() + or length() have been redefined by the user + File: redfit.R -------------- Modified: pkg/dplR/DESCRIPTION =================================================================== --- pkg/dplR/DESCRIPTION 2014-01-14 18:05:30 UTC (rev 725) +++ pkg/dplR/DESCRIPTION 2014-01-15 11:15:43 UTC (rev 726) @@ -3,7 +3,7 @@ Type: Package Title: Dendrochronology Program Library in R Version: 1.5.8 -Date: 2014-01-14 +Date: 2014-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", Modified: pkg/dplR/src/redfit.c =================================================================== --- pkg/dplR/src/redfit.c 2014-01-14 18:05:30 UTC (rev 725) +++ pkg/dplR/src/redfit.c 2014-01-15 11:15:43 UTC (rev 726) @@ -104,7 +104,7 @@ SETCAR(tmp, lmfit); tmp = CDR(tmp); SETCAR(tmp, x); tmp = CDR(tmp); SETCAR(tmp, y); - PROTECT(lmres = eval(lmcall, R_GlobalEnv)); + PROTECT(lmres = eval(lmcall, R_EmptyEnv)); /* dplR: get residuals from the list given by lm.fit(x, y) */ lmnames = getAttrib(lmres, R_NamesSymbol); @@ -112,7 +112,7 @@ SET_TYPEOF(ncall, LANGSXP); SETCAR(tmp, lengthfun); tmp = CDR(tmp); SETCAR(tmp, lmnames); - PROTECT_WITH_INDEX(sn = eval(ncall, R_GlobalEnv), &ipx); + PROTECT_WITH_INDEX(sn = eval(ncall, R_BaseEnv), &ipx); REPROTECT(sn = coerceVector(sn, REALSXP), ipx); nameslength = (size_t) *REAL(sn); UNPROTECT(2); @@ -130,13 +130,13 @@ SET_TYPEOF(ncall, LANGSXP); SETCAR(tmp, lengthfun); tmp = CDR(tmp); SETCAR(tmp, y); - PROTECT_WITH_INDEX(sn = eval(ncall, R_GlobalEnv), &ipx); + PROTECT_WITH_INDEX(sn = eval(ncall, R_BaseEnv), &ipx); REPROTECT(sn = coerceVector(sn, REALSXP), ipx); n = (size_t) *REAL(sn); UNPROTECT(1); if (found) { SETCAR(tmp, rduals); - PROTECT_WITH_INDEX(sn = eval(ncall, R_GlobalEnv), &ipx); + PROTECT_WITH_INDEX(sn = eval(ncall, R_BaseEnv), &ipx); REPROTECT(sn = coerceVector(sn, REALSXP), ipx); mismatch = n != (size_t) *REAL(sn); UNPROTECT(1); @@ -205,7 +205,7 @@ SETCAR(tmp, install("cbind")); tmp = CDR(tmp); SETCAR(tmp, ScalarReal(1.0)); tmp = CDR(tmp); SETCAR(tmp, twk); - REPROTECT(twk = eval(cbindcall, R_GlobalEnv), pidx); + REPROTECT(twk = eval(cbindcall, R_BaseEnv), pidx); /* dplR: twk_data points to the non-constant column; the constant * column will not be altered */ twk_data = REAL(twk) + nseg_val; From noreply at r-forge.r-project.org Wed Jan 15 12:25:47 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 15 Jan 2014 12:25:47 +0100 (CET) Subject: [Dplr-commits] r727 - pkg/dplR/src Message-ID: <20140115112547.7E52A18625B@r-forge.r-project.org> Author: mvkorpel Date: 2014-01-15 12:25:14 +0100 (Wed, 15 Jan 2014) New Revision: 727 Modified: pkg/dplR/src/redfit.c Log: Updated years in Copyright notice Modified: pkg/dplR/src/redfit.c =================================================================== --- pkg/dplR/src/redfit.c 2014-01-15 11:15:43 UTC (rev 726) +++ pkg/dplR/src/redfit.c 2014-01-15 11:25:14 UTC (rev 727) @@ -2,7 +2,7 @@ * ftfix and makear1 are based on program REDFIT. See redfit.R. * Author of the dplR version is Mikko Korpela. * - * Copyright (C) 2013 Aalto University + * Copyright (C) 2013-2014 Aalto University * * This program is free software; you can redistribute it and/or * modify it under the terms of the GNU General Public License as From noreply at r-forge.r-project.org Wed Jan 15 16:15:12 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Wed, 15 Jan 2014 16:15:12 +0100 (CET) Subject: [Dplr-commits] r728 - in pkg/dplR: . R Message-ID: <20140115151512.41A61185371@r-forge.r-project.org> Author: mvkorpel Date: 2014-01-15 16:15:11 +0100 (Wed, 15 Jan 2014) New Revision: 728 Modified: pkg/dplR/ChangeLog pkg/dplR/R/tbrm.R Log: tbrm.R: Check that C has length 1 Modified: pkg/dplR/ChangeLog =================================================================== --- pkg/dplR/ChangeLog 2014-01-15 11:25:14 UTC (rev 727) +++ pkg/dplR/ChangeLog 2014-01-15 15:15:11 UTC (rev 728) @@ -53,8 +53,14 @@ be DFT-even - Computed more precise values for the 6 dB bandwidths of each window, also for short windows. Uniform sampling was assumed. -- Two internal functions moved to top level, previously inside print.redfit() +- Two internal functions moved to top level, previously inside + print.redfit() +File: tbrm.R +------------ + +- Check that C has length 1 + * CHANGES IN dplR VERSION 1.5.7 File: DESCRIPTION Modified: pkg/dplR/R/tbrm.R =================================================================== --- pkg/dplR/R/tbrm.R 2014-01-15 11:25:14 UTC (rev 727) +++ pkg/dplR/R/tbrm.R 2014-01-15 15:15:11 UTC (rev 728) @@ -2,7 +2,8 @@ { y <- as.double(x[!is.na(x)]) n <- as.integer(length(y)) - stopifnot(!is.na(n)) - .C(dplR.tbrm, y, n, as.double(C), result = double(1L), NAOK = TRUE, + C2 <- as.double(C) + stopifnot(!is.na(n), length(C2) == 1) + .C(dplR.tbrm, y, n, C2, result = double(1L), NAOK = TRUE, DUP = FALSE)$result } From noreply at r-forge.r-project.org Thu Jan 16 13:22:26 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Thu, 16 Jan 2014 13:22:26 +0100 (CET) Subject: [Dplr-commits] r729 - in tags: . dplR-1.5.8 Message-ID: <20140116122226.8EBB6184CEF@r-forge.r-project.org> Author: mvkorpel Date: 2014-01-16 13:22:26 +0100 (Thu, 16 Jan 2014) New Revision: 729 Added: tags/dplR-1.5.8/ Log: dplR 1.5.8 Property changes on: tags/dplR-1.5.8 ___________________________________________________________________ Added: svn:ignore + dplR-Ex.R Added: svn:mergeinfo + /branches/dplR-R-2.15:466-506 /branches/redfit:662-700 From noreply at r-forge.r-project.org Sun Jan 19 21:00:33 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Sun, 19 Jan 2014 21:00:33 +0100 (CET) Subject: [Dplr-commits] r730 - in pkg/dplR: . R inst/unitTests src Message-ID: <20140119200034.205AA186C42@r-forge.r-project.org> Author: mvkorpel Date: 2014-01-19 21:00:33 +0100 (Sun, 19 Jan 2014) New Revision: 730 Added: pkg/dplR/src/dplR.c Modified: pkg/dplR/ChangeLog pkg/dplR/DESCRIPTION pkg/dplR/R/exactmean.R pkg/dplR/R/gini.coef.R pkg/dplR/R/read.tucson.R pkg/dplR/R/sens1.R pkg/dplR/R/sens2.R pkg/dplR/R/tbrm.R pkg/dplR/inst/unitTests/runit.dplR.R pkg/dplR/inst/unitTests/runit.io.R pkg/dplR/src/dplR.h pkg/dplR/src/exactmean.c pkg/dplR/src/exactsum.c pkg/dplR/src/exactsum.h pkg/dplR/src/gini.c pkg/dplR/src/rcompact.c pkg/dplR/src/readloop.c pkg/dplR/src/redfit.c pkg/dplR/src/sens.c pkg/dplR/src/tbrm.c Log: - First changes for future dplR version 1.5.9 - Using .Call() instead of .C() when interfacing with C code - Fixed a probably unnoticeable bug in the C code called by read.tucson() - More efficient computation of the gini coefficient - Some reorganization of the C code / headers - More RUnit tests for gini.coef(), also one more for read.tucson() Modified: pkg/dplR/ChangeLog =================================================================== --- pkg/dplR/ChangeLog 2014-01-16 12:22:26 UTC (rev 729) +++ pkg/dplR/ChangeLog 2014-01-19 20:00:33 UTC (rev 730) @@ -1,3 +1,48 @@ +* CHANGES IN dplR VERSION 1.5.9 + +Files: dplR.h, rcompact.c, redfit.c +----------------------------------- + +- Restructured header inclusions +- dplR.h declares new function dplRlength (internal use) + +File: dplR.c +------------ + +- New file for general C functions internally used by dplR + +Files: exactmean.c, exactmean.R, gini.c, gini.coef.R, +readloop.c, read.tucson.R, sens.c, sens1.R, sens2.R, tbrm.c, tbrm.R +------------------------------------------------------------------- + +- Use .Call() instead of .C() for interfacing with C code +- The C functions need less support (arguments, argument checking) from + the calling R function + +Files: exactsum.c, exactsum.h +----------------------------- + +- Reuse of code between function by using the C preprocessor +- New (internal to dplR C code) function cumsum (cumulative sum, + overwrites input array) +- size_t n + +File: gini.c +------------ + +- Simplified expression for gini coefficent reduces number of + arithmetic operations performed +- Fewer calls to other functions (use of the new cumulative sum function) + +File: readloop.c +---------------- + +- Fixed buggy handling of malformed Tucson format series that have + no data and no stop marker. Previously, this hypothetical case + could have caused a read from a location just outside the array + bounds. However, in most cases that would probably not have been a + problem. + * CHANGES IN dplR VERSION 1.5.8 File: tbrm.Rd Modified: pkg/dplR/DESCRIPTION =================================================================== --- pkg/dplR/DESCRIPTION 2014-01-16 12:22:26 UTC (rev 729) +++ pkg/dplR/DESCRIPTION 2014-01-19 20:00:33 UTC (rev 730) @@ -2,8 +2,8 @@ Package: dplR Type: Package Title: Dendrochronology Program Library in R -Version: 1.5.8 -Date: 2014-01-15 +Version: 1.5.9 +Date: 2014-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/R/exactmean.R =================================================================== --- pkg/dplR/R/exactmean.R 2014-01-16 12:22:26 UTC (rev 729) +++ pkg/dplR/R/exactmean.R 2014-01-19 20:00:33 UTC (rev 730) @@ -1,9 +1,5 @@ `exactmean` <- function(x) { ## Drops NA and NaN values! - y <- as.double(x[!is.na(x)]) - n <- as.integer(length(y)) - stopifnot(!is.na(n)) - .C(dplR.mean, - y, n, result=NaN*double(1L), NAOK=TRUE, DUP=FALSE)$result + .Call(dplR.mean, as.double(x[!is.na(x)])) } Modified: pkg/dplR/R/gini.coef.R =================================================================== --- pkg/dplR/R/gini.coef.R 2014-01-16 12:22:26 UTC (rev 729) +++ pkg/dplR/R/gini.coef.R 2014-01-19 20:00:33 UTC (rev 730) @@ -1,8 +1,4 @@ `gini.coef` <- function(x) { - y <- as.double(x[!is.na(x)]) - n <- as.integer(length(y)) - stopifnot(!is.na(n)) - .C(dplR.gini, - y, n, result=double(1L), NAOK=TRUE, DUP=FALSE)$result + .Call(dplR.gini, as.double(x[!is.na(x)])) } Modified: pkg/dplR/R/read.tucson.R =================================================================== --- pkg/dplR/R/read.tucson.R 2014-01-16 12:22:26 UTC (rev 729) +++ pkg/dplR/R/read.tucson.R 2014-01-19 20:00:33 UTC (rev 730) @@ -305,20 +305,30 @@ } series.ids <- unique(series) nseries <- length(series.ids) - series.index <- match(series, series.ids) + ## At this time match does not support long vectors in the second + ## argument and always returns integers, but let's check the + ## result anyway. + series.index <- tryCatch(as.integer(match(series, series.ids)), + warning = conditionMessage, + error = conditionMessage) + if (!is.integer(series.index)) { + stop(gettextf("series.index must be integer: %s", + paste(as.character(series.index), collapse = ", "), + domain = "R-dplR")) + } extra.col <- dat[[13]] - min.year <- min(decade.yr) - max.year <- ((max(decade.yr)+10) %/% 10) * 10 - span <- max.year - min.year + 1 - rw.vec <- NA*vector(mode="numeric", length=nseries*span) - scratch <- rep.int(as.integer(min.year-1), nseries) - prec.rproc <- rep.int(as.integer(1), nseries) - .C(rwl.readloop, series.index, decade.yr, as.vector(x), - nrow(x), ncol(x), as.integer(min.year), rw.vec, - as.integer(span), as.integer(nseries), scratch, prec.rproc, - NAOK=TRUE, DUP=FALSE) - rw.mat <- matrix(rw.vec, ncol=nseries, nrow=span) + res <- .Call(rwl.readloop, series.index, decade.yr, x) + rw.mat <- res[[1]] + min.year <- res[[2]] + prec.rproc <- res[[3]] + span <- nrow(rw.mat) + if (span == 0) { + rw.df <- as.data.frame(rw.mat) + names(rw.df) <- as.character(series.ids) + return(rw.df) + } + max.year <- min.year + (span - 1) rownames(rw.mat) <- min.year:max.year ## The operations in the loop depend on the precision of each series. Modified: pkg/dplR/R/sens1.R =================================================================== --- pkg/dplR/R/sens1.R 2014-01-16 12:22:26 UTC (rev 729) +++ pkg/dplR/R/sens1.R 2014-01-19 20:00:33 UTC (rev 730) @@ -1,8 +1,4 @@ `sens1` <- function(x) { - y <- as.double(x[!is.na(x)]) - n <- as.integer(length(y)) - stopifnot(!is.na(n)) - .C(dplR.sens1, - y, n, result=NaN*double(1L), NAOK=TRUE, DUP=FALSE)$result + .Call(dplR.sens1, as.double(x[!is.na(x)])) } Modified: pkg/dplR/R/sens2.R =================================================================== --- pkg/dplR/R/sens2.R 2014-01-16 12:22:26 UTC (rev 729) +++ pkg/dplR/R/sens2.R 2014-01-19 20:00:33 UTC (rev 730) @@ -1,8 +1,4 @@ `sens2` <- function(x) { - y <- as.double(x[!is.na(x)]) - n <- as.integer(length(y)) - stopifnot(!is.na(n)) - .C(dplR.sens2, - y, n, result=NaN*double(1L), NAOK=TRUE, DUP=FALSE)$result + .Call(dplR.sens2, as.double(x[!is.na(x)])) } Modified: pkg/dplR/R/tbrm.R =================================================================== --- pkg/dplR/R/tbrm.R 2014-01-16 12:22:26 UTC (rev 729) +++ pkg/dplR/R/tbrm.R 2014-01-19 20:00:33 UTC (rev 730) @@ -1,9 +1,4 @@ `tbrm` <- function(x, C=9) { - y <- as.double(x[!is.na(x)]) - n <- as.integer(length(y)) - C2 <- as.double(C) - stopifnot(!is.na(n), length(C2) == 1) - .C(dplR.tbrm, y, n, C2, result = double(1L), NAOK = TRUE, - DUP = FALSE)$result + .Call(dplR.tbrm, as.double(x[!is.na(x)]), C) } Modified: pkg/dplR/inst/unitTests/runit.dplR.R =================================================================== --- pkg/dplR/inst/unitTests/runit.dplR.R 2014-01-16 12:22:26 UTC (rev 729) +++ pkg/dplR/inst/unitTests/runit.dplR.R 2014-01-19 20:00:33 UTC (rev 730) @@ -461,11 +461,34 @@ test.gini.coef <- function() { ## Setup - SAMP.SIZE <- 1000 + MAX.SIZE <- 1000 + NTIMES <- 10 + samp <- sample(seq.int(2, MAX.SIZE), max(0, min(NTIMES, MAX.SIZE - 1))) ## Test - checkEquals(0, gini.coef(rep(42, SAMP.SIZE)), + 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)) + checkEquals(1 - 1 / samp, coefs[1, ], + msg="Winner takes all: 1 - 1/n") + checkEquals(1 - coefs[4, ] / samp, coefs[2, ], + msg="k (random) equal winners, others get 0: 1 - k/n") + checkEquals(numeric(length(samp)), coefs[3, ], msg="Gini coefficient of a set with total equality is 0") - ## Needs more tests } test.glk <- function() { Modified: pkg/dplR/inst/unitTests/runit.io.R =================================================================== --- pkg/dplR/inst/unitTests/runit.io.R 2014-01-16 12:22:26 UTC (rev 729) +++ pkg/dplR/inst/unitTests/runit.io.R 2014-01-19 20:00:33 UTC (rev 730) @@ -175,4 +175,14 @@ msg="Row names are correct (test 12)") checkEqualsNumeric(c(12.3, 4.56, 7.89, 0.12, 0.34, 0.05, 6.78), res.tf12[[1]], msg="Data are correct (test 12)") + + ## File has no data (invalid file) + tf13 <- tempfile() + fh13 <- file(tf13, "wt") + on.exit(unlink(tf13)) + writeLines("TST13A 1734", fh13) + close(fh13) + checkEquals(0, nrow(read.tucson(tf13, header = FALSE)), + msg="Detect when file has no measurement data (test 13)") + } Added: pkg/dplR/src/dplR.c =================================================================== --- pkg/dplR/src/dplR.c (rev 0) +++ pkg/dplR/src/dplR.c 2014-01-19 20:00:33 UTC (rev 730) @@ -0,0 +1,16 @@ +#include "dplR.h" + +size_t dplRlength(SEXP x) { + size_t xlength; + SEXP sn, tmp, ncall; + PROTECT_INDEX ipx; + PROTECT(tmp = ncall = allocList(2)); + SET_TYPEOF(ncall, LANGSXP); + SETCAR(tmp, install("length")); tmp = CDR(tmp); + SETCAR(tmp, x); + PROTECT_WITH_INDEX(sn = eval(ncall, R_BaseEnv), &ipx); + REPROTECT(sn = coerceVector(sn, REALSXP), ipx); + xlength = (size_t) *REAL(sn); + UNPROTECT(2); + return xlength; +} Modified: pkg/dplR/src/dplR.h =================================================================== --- pkg/dplR/src/dplR.h 2014-01-16 12:22:26 UTC (rev 729) +++ pkg/dplR/src/dplR.h 2014-01-19 20:00:33 UTC (rev 730) @@ -2,6 +2,9 @@ #define DPLR_H #include /* to include Rconfig.h */ +#include +#include +size_t dplRlength(SEXP x); #ifdef ENABLE_NLS #include @@ -11,4 +14,8 @@ #define dngettext(pkg, String, StringP, N) (N > 1 ? StringP: String) #endif +#if defined(R_VERSION) && R_VERSION >= R_Version(3, 0, 0) +#define DPLR_RGEQ3 #endif + +#endif Modified: pkg/dplR/src/exactmean.c =================================================================== --- pkg/dplR/src/exactmean.c 2014-01-16 12:22:26 UTC (rev 729) +++ pkg/dplR/src/exactmean.c 2014-01-19 20:00:33 UTC (rev 730) @@ -1,10 +1,16 @@ #include +#include "dplR.h" #include "exactsum.h" -void exactmean(double *x, int *n_ptr, double *result){ - int n = *n_ptr; +SEXP exactmean(SEXP x){ + SEXP ans; listnode expansion; + size_t n; expansion.next = NULL; - - *result = msum(x, n, &expansion) / n; + n = dplRlength(x); + ans = PROTECT(allocVector(REALSXP, 1)); + /* Note: x must be a numeric vector */ + REAL(ans)[0] = msum(REAL(x), n, &expansion) / n; + UNPROTECT(1); + return ans; } Modified: pkg/dplR/src/exactsum.c =================================================================== --- pkg/dplR/src/exactsum.c 2014-01-16 12:22:26 UTC (rev 729) +++ pkg/dplR/src/exactsum.c 2014-01-19 20:00:33 UTC (rev 730) @@ -3,8 +3,50 @@ #include "exactsum.h" /* Written by Mikko Korpela. */ -dplr_double msum(double *array, int n, listnode *expansion){ - int k; + +/* Common building block for functions below */ +#define GROWEXP_Body \ + /* Grow-Expansion(expansion, a) */ \ + readptr = expansion; \ + writeptr = expansion; \ + while(readptr != NULL && readptr->valid == TRUE) { \ + /* Updating readptr is easy: just do it once in the loop */ \ + /* and stay ahead of writeptr */ \ + b = readptr->data; \ + readptr = readptr->next; \ + /* Two-Sum(a,b): x + y == a + b */ \ + x = a + b; \ + b_virtual = x - a; \ + a_virtual = x - b_virtual; \ + b_roundoff = b - b_virtual; \ + a_roundoff = a - a_virtual; \ + y = a_roundoff + b_roundoff; \ + if(y != 0){ \ + writeptr->data = y; \ + /* Loosely specified invariant: always have writeptr */ \ + /* point to a writable location */ \ + if(writeptr->next != NULL){ \ + writeptr = writeptr->next; \ + } else{ \ + writeptr->next = \ + (listnode *) R_alloc(1, sizeof(listnode)); \ + writeptr = writeptr->next; \ + writeptr->next = NULL; \ + } \ + } \ + a = x; \ + } \ + writeptr->data = a; \ + writeptr->valid = TRUE; \ + \ + /* The possible tail of the list is effectively cut (number of */ \ + /* non-zero elements may decrease), but any allocated space */ \ + /* remains there */ \ + if(writeptr->next != NULL) \ + writeptr->next->valid = FALSE; + +dplr_double msum(double *array, size_t n, listnode *expansion){ + size_t k; dplr_double a,b,a_virtual,b_virtual,a_roundoff,b_roundoff,x,y,total; listnode *readptr, *writeptr; @@ -13,45 +55,8 @@ /* Loop through array */ for(k=0; kvalid == TRUE) { - /* Updating readptr is easy: just do it once in the loop - and stay ahead of writeptr */ - b = readptr->data; - readptr = readptr->next; - /* Two-Sum(a,b): x + y == a + b */ - x = a + b; - b_virtual = x - a; - a_virtual = x - b_virtual; - b_roundoff = b - b_virtual; - a_roundoff = a - a_virtual; - y = a_roundoff + b_roundoff; - if(y != 0){ - writeptr->data = y; - /* Loosely specified invariant: always have writeptr - point to a writable location */ - if(writeptr->next != NULL){ - writeptr = writeptr->next; - } else{ - writeptr->next = - (listnode *) R_alloc(1, sizeof(listnode)); - writeptr = writeptr->next; - writeptr->next = NULL; - } - } - a = x; - } - writeptr->data = a; /* sum of the list is sum of array[0]..array[k] */ - writeptr->valid = TRUE; - - /* The possible tail of the list is effectively cut (number of - non-zero elements may decrease), but any allocated space - remains there */ - if(writeptr->next != NULL) - writeptr->next->valid = FALSE; + GROWEXP_Body } /* Add together the elements of the expansion */ @@ -63,47 +68,37 @@ return(total); } -/* Copy-paste of the insides of the for loop in msum */ -void grow_exp(listnode *expansion, dplr_double a){ - dplr_double b,a_virtual,b_virtual,a_roundoff,b_roundoff,x,y; - listnode *readptr, *writeptr; +/* Cumulative sum, overwrites array */ +dplr_double cumsum(double *array, size_t n, listnode *expansion){ + size_t k; + dplr_double a,b,a_virtual,b_virtual,a_roundoff,b_roundoff,x,y,total; + listnode *readptr, *writeptr, *tmp; + total = 0.0f; - /* Grow-Expansion(expansion, array[k]) */ - readptr = expansion; - writeptr = expansion; - while(readptr != NULL && readptr->valid == TRUE) { - /* Updating readptr is easy: just do it once in the loop - and stay ahead of writeptr */ - b = readptr->data; - readptr = readptr->next; - /* Two-Sum(a,b): x + y == a + b */ - x = a + b; - b_virtual = x - a; - a_virtual = x - b_virtual; - b_roundoff = b - b_virtual; - a_roundoff = a - a_virtual; - y = a_roundoff + b_roundoff; - if(y != 0){ - writeptr->data = y; - /* Loosely specified invariant: always have writeptr - point to a writable location */ - if(writeptr->next != NULL){ - writeptr = writeptr->next; - } else{ - writeptr->next = (listnode *) R_alloc(1, sizeof(listnode)); - writeptr = writeptr->next; - writeptr->next = NULL; - } + /* Old data are not valid anymore */ + expansion->valid = FALSE; + + /* Loop through array */ + for(k=0; kvalid == TRUE){ + total += tmp->data; + tmp = tmp->next; } - a = x; + /* Overwrite array with cumulative sum */ + array[k] = (double)total; } - writeptr->data = a; /* sum of the list is sum of array[0]..array[k] */ - writeptr->valid = TRUE; - /* The possible tail of the list is effectively cut (number of - non-zero elements may decrease), but any allocated space - remains there */ - if(writeptr->next != NULL) - writeptr->next->valid = FALSE; + return(total); +} +void grow_exp(listnode *expansion, dplr_double a){ + dplr_double b,a_virtual,b_virtual,a_roundoff,b_roundoff,x,y; + listnode *readptr, *writeptr; + + GROWEXP_Body } Modified: pkg/dplR/src/exactsum.h =================================================================== --- pkg/dplR/src/exactsum.h 2014-01-16 12:22:26 UTC (rev 729) +++ pkg/dplR/src/exactsum.h 2014-01-19 20:00:33 UTC (rev 730) @@ -100,8 +100,11 @@ array, because the list usually only has a handful of elements. Output: the sum of the numbers */ -dplr_double msum(double *array, int n, listnode *expansion); +dplr_double msum(double *array, size_t n, listnode *expansion); +/* Cumulative sum, overwrites array */ +dplr_double cumsum(double *array, size_t n, listnode *expansion); + /* Add number a to the sum represented by expansion */ void grow_exp(listnode *expansion, dplr_double a); Modified: pkg/dplR/src/gini.c =================================================================== --- pkg/dplR/src/gini.c 2014-01-16 12:22:26 UTC (rev 729) +++ pkg/dplR/src/gini.c 2014-01-19 20:00:33 UTC (rev 730) @@ -1,68 +1,51 @@ -#include #include +#include +#include "dplR.h" #include "exactsum.h" /* Written by Mikko Korpela */ -void gini(double *x_const, int *n_ptr, double *result){ - int i; - double *x; - dplr_double sum1, sum2; - listnode tmp1, tmp2, *tmp_p; - int n = *n_ptr; +SEXP gini(SEXP x){ + SEXP ans; + double *x_const, *x2; + dplr_double sum; + listnode tmp; + size_t i, n; + n = dplRlength(x); + ans = PROTECT(allocVector(REALSXP, 1)); if(n < 2){ - *result = 0.0f; - return; + REAL(ans)[0] = 0.0f; + UNPROTECT(1); + return ans; } + /* Note: x must be a numeric vector */ + x_const = REAL(x); /* Sort the numbers */ - x = (double *) R_alloc(n, sizeof(double)); + x2 = (double *) R_alloc(n, sizeof(double)); for(i = 0; i < n; i++) - x[i] = x_const[i]; - R_qsort(x, 1, n); + x2[i] = x_const[i]; +#ifdef DPLR_RGEQ3 + R_qsort(x2, 1, n); +#else + /* In R < 3.0.0, n will not be larger than INT_MAX, and R_qsort + * takes int indices */ + R_qsort(x2, 1, (int)n); +#endif - /* Setup for grow_exp */ - tmp1.next = NULL; - tmp1.data = x[0]; - tmp1.valid = TRUE; + /* Setup for cumsum, msum */ + tmp.next = NULL; - /* Cumulative sum */ - for(i = 1; i < n; i++){ - grow_exp(&tmp1, x[i]); - tmp_p = &tmp1; - sum1 = 0.0f; - while(tmp_p != NULL && tmp_p->valid == TRUE){ - sum1 += tmp_p->data; - tmp_p = tmp_p->next; - } - x[i] = sum1; - } + /* Cumulative sum (overwrites x2) */ + sum = cumsum(x2, n, &tmp); - /* Setup for grow_exp */ - if(tmp1.next != NULL) - tmp1.next->valid = FALSE; - tmp2.next = NULL; - - /* Gini */ - tmp1.data = (dplr_double)x[n-1] * (n-1); - tmp2.data = x[0]; - tmp2.valid = TRUE; - grow_exp(&tmp2, x[0]); - for(i = 1; i < n-1; i++){ - grow_exp(&tmp1, (dplr_double)x[i] * i); - grow_exp(&tmp2, (dplr_double)x[i] * (i+2)); - } - sum1 = 0.0f; - tmp_p = &tmp1; - while(tmp_p != NULL && tmp_p->valid == TRUE){ - sum1 += tmp_p->data; - tmp_p = tmp_p->next; - } - sum2 = 0.0f; - tmp_p = &tmp2; - while(tmp_p != NULL && tmp_p->valid == TRUE){ - sum2 += tmp_p->data; - tmp_p = tmp_p->next; - } - *result = (sum1-sum2) / ((dplr_double)x[n-1]*n); + /* Gini. The following reformulation highlights the "maximum + * inequality" gini coefficient of 1 - 1/n (assuming no negative + * samples): + * + * 1 - 1/n - 2 * msum(x2, n - 1, &tmp) / (sum * n) + */ + REAL(ans)[0] = (sum * (n - 1) - 2 * msum(x2, n - 1, &tmp)) / (sum * n); + UNPROTECT(1); + return ans; } Modified: pkg/dplR/src/rcompact.c =================================================================== --- pkg/dplR/src/rcompact.c 2014-01-16 12:22:26 UTC (rev 729) +++ pkg/dplR/src/rcompact.c 2014-01-19 20:00:33 UTC (rev 730) @@ -1,5 +1,4 @@ #include "dplR.h" -#include #include #include #include Modified: pkg/dplR/src/readloop.c =================================================================== --- pkg/dplR/src/readloop.c 2014-01-16 12:22:26 UTC (rev 729) +++ pkg/dplR/src/readloop.c 2014-01-19 20:00:33 UTC (rev 730) @@ -1,33 +1,117 @@ -#include +#include "dplR.h" +#include +#include /* A function to speed up the heaviest part of read.tucson.R */ /* Written by Mikko Korpela */ -void readloop(int *series_index, int *decade, - int *x, int *x_nrow_p, int *x_ncol_p, int *min_year_p, - double *rw_mat, int *rw_nrow_p, int *rw_ncol_p, - int *last_yr, int *prec_rproc){ - int i, j, yr_idx, rw_idx, x_idx, this_series, this_val, - this_decade, last_valid; +SEXP readloop(SEXP series_index, SEXP decade, SEXP x) { + SEXP ans, dims, rw_mat, prec_rproc; + size_t i, x_nrow, rw_nrow, rw_ncol, x_idx; + int j, x_ncol, yr_idx, rw_idx, this_series, this_val, min_year, max_year; + int span, this_decade, last_valid, nseries; + int *series_index_p, *decade_p, *x_p, *prec_rproc_p, *last_yr; double stop_marker; - int x_nrow = *x_nrow_p; - int x_ncol = *x_ncol_p; - int min_year = *min_year_p; - int rw_nrow = *rw_nrow_p; - int rw_ncol = *rw_ncol_p; + double *dims_p, *rw_vec; + /* Safety checks */ + if (!(isInteger(series_index) && isInteger(decade) && isInteger(x))) { + error(_("all arguments must be integers")); + } + + /* Dimensions of x */ + dims = PROTECT(coerceVector(getAttrib(x, R_DimSymbol), REALSXP)); + if (length(dims) != 2) { + UNPROTECT(1); + error(_("'x' must be a matrix")); + } + dims_p = REAL(dims); + /* Nominally max 10 years per row, allow a few more */ + if (dims_p[1] > 100) { + UNPROTECT(1); + error(_("too many columns in 'x'")); + } + x_nrow = (size_t) dims_p[0]; + x_ncol = (int) dims_p[1]; + UNPROTECT(1); + + /* More safety checks */ + if (!(dplRlength(series_index) == x_nrow && + dplRlength(decade) == x_nrow)) { + error(_("dimensions of 'x', 'series_index' and 'decade' must match")); + } + + series_index_p = INTEGER(series_index); + decade_p = INTEGER(decade); + x_p = INTEGER(x); + + /* Calculate dimensions of result matrix */ + nseries = 0; + min_year = INT_MAX; + max_year = INT_MIN; + for (i = 0; i < x_nrow; i++) { + if (series_index_p[i] < 1) { + error(_("'series_index' must be positive")); + } + nseries = imax2(nseries, series_index_p[i]); + this_decade = decade_p[i]; + j = x_ncol - 1; + x_idx = i + j * x_nrow; + while (j >= 0 && x_p[x_idx] == NA_INTEGER) { + --j; + x_idx -= x_nrow; + } + if (j >= 0) { + min_year = imin2(min_year, this_decade); + max_year = imax2(max_year, this_decade + j); + } + } + if (max_year >= min_year) { + span = max_year - min_year + 1; + } else { + min_year = NA_INTEGER; + span = 0; + } + rw_nrow = (size_t) span; + rw_ncol = (size_t) nseries; + + /* List for results: rw_mat, min_year, prec_rproc */ + ans = PROTECT(allocVector(VECSXP, 3)); + rw_mat = SET_VECTOR_ELT(ans, 0, allocMatrix(REALSXP, span, nseries)); + rw_vec = REAL(rw_mat); + for (i = 0; i < rw_nrow * rw_ncol; i++) { + rw_vec[i] = NA_REAL; + } + SET_VECTOR_ELT(ans, 1, ScalarInteger(min_year)); + prec_rproc = SET_VECTOR_ELT(ans, 2, allocVector(INTSXP, nseries)); + prec_rproc_p = INTEGER(prec_rproc); + if (span == 0) { + for(i = 0; i < rw_ncol; i++){ + prec_rproc_p[i] = NA_INTEGER; + } + warning(_("no data found in 'x'")); + UNPROTECT(1); + return ans; + } + + /* Allocate internal storage */ + last_yr = (int *) R_alloc(rw_ncol, sizeof(int)); + for (i = 0; i < rw_ncol; i++) { + last_yr[i] = min_year; + } + /* Convert between input and output formats */ for(i = 0; i < x_nrow; i++){ - this_decade = decade[i]; + this_decade = decade_p[i]; yr_idx = this_decade - min_year; - this_series = series_index[i] - 1; + this_series = series_index_p[i] - 1; rw_idx = this_series * rw_nrow + yr_idx; x_idx = i; last_valid = last_yr[this_series]; for(j = 0; j < x_ncol; j++){ - this_val = x[x_idx]; + this_val = x_p[x_idx]; x_idx += x_nrow; if(this_val != NA_INTEGER){ - rw_mat[rw_idx] = this_val; + rw_vec[rw_idx] = this_val; last_valid = this_decade + j; } rw_idx++; @@ -38,11 +122,16 @@ last_yr[this_series] = last_valid; } for(i = 0; i < rw_ncol; i++){ - stop_marker = rw_mat[i * rw_nrow + last_yr[i] - min_year]; + stop_marker = rw_vec[i * rw_nrow + (last_yr[i] - min_year)]; if(stop_marker == 999.0f){ - prec_rproc[i] = 100; + prec_rproc_p[i] = 100; } else if(stop_marker == -9999.0f){ - prec_rproc[i] = 1000; + prec_rproc_p[i] = 1000; + } else { + prec_rproc_p[i] = 1; } } + + UNPROTECT(1); + return ans; } Modified: pkg/dplR/src/redfit.c =================================================================== --- pkg/dplR/src/redfit.c 2014-01-16 12:22:26 UTC (rev 729) +++ pkg/dplR/src/redfit.c 2014-01-19 20:00:33 UTC (rev 730) @@ -19,7 +19,6 @@ */ #include "dplR.h" -#include #include #include #include Modified: pkg/dplR/src/sens.c =================================================================== --- pkg/dplR/src/sens.c 2014-01-16 12:22:26 UTC (rev 729) +++ pkg/dplR/src/sens.c 2014-01-19 20:00:33 UTC (rev 730) @@ -1,19 +1,25 @@ -#include #include +#include "dplR.h" #include "exactsum.h" /* Written by Mikko Korpela */ -void sens2(double *x_const, int *n_ptr, double *result){ - int i; +SEXP sens2(SEXP x){ + SEXP ans; + size_t i, n; double previous, this, next; + double *x_const; dplr_double sum1, sum2; listnode tmp, *tmp_p; - int n = *n_ptr; + n = dplRlength(x); + ans = PROTECT(allocVector(REALSXP, 1)); if(n < 2){ - *result = R_NaN; - return; + REAL(ans)[0] = R_NaN; + UNPROTECT(1); + return ans; } + /* Note: x must be a numeric vector */ + x_const = REAL(x); /* Setup for grow_exp and msum */ tmp.next = NULL; @@ -70,20 +76,28 @@ } sum2 = msum(x_const, n, &tmp); - *result = sum1/(sum2-sum2/n); + REAL(ans)[0] = sum1/(sum2-sum2/n); + UNPROTECT(1); + return ans; } /* Written by Mikko Korpela */ -void sens1(double *x_const, int *n_ptr, double *result){ - int i; +SEXP sens1(SEXP x){ + SEXP ans; + size_t i, n; dplr_double sum, previous, this, term; + double *x_const; listnode tmp, *tmp_p; - int n = *n_ptr; + n = dplRlength(x); + ans = PROTECT(allocVector(REALSXP, 1)); if(n < 2){ - *result = R_NaN; - return; + REAL(ans)[0] = R_NaN; + UNPROTECT(1); + return ans; } + /* Note: x must be a numeric vector */ + x_const = REAL(x); /* Setup for grow_exp */ tmp.next = NULL; @@ -105,5 +119,7 @@ tmp_p = tmp_p->next; } - *result = (sum+sum)/(n-1); + REAL(ans)[0] = (sum+sum)/(n-1); + UNPROTECT(1); + return ans; } Modified: pkg/dplR/src/tbrm.c =================================================================== --- pkg/dplR/src/tbrm.c 2014-01-16 12:22:26 UTC (rev 729) +++ pkg/dplR/src/tbrm.c 2014-01-19 20:00:33 UTC (rev 730) @@ -1,65 +1,79 @@ -#include +#include #include +#include "dplR.h" #include "exactsum.h" /* Tukey's Biweight Robust Mean (tbrm). - When called directly, there must be no NAs in 'x_const'. - This function only alters the argument 'result' - => DUP=FALSE is safe (and the fastest, preferred way). + There must be no NAs in 'x'. Input: - - x_const Array of numbers to be summarized by tbrm - - n_ptr Pointer to the length of the array - - C_ptr Pointer to parameter C which adjusts the scaling of the data - - result Pointer to storage location of the result. - Output: No return value. The tbrm is written to *result. + - x Array of numbers to be summarized by tbrm (double) + - C Parameter C which adjusts the scaling of the data (double, length 1) + Output: numeric vector of length 1 Written by Mikko Korpela. */ -void tbrm(double *x_const, int *n_ptr, double *C_ptr, double *result){ +SEXP tbrm(SEXP x, SEXP C){ + SEXP ans, C2; Rboolean n_odd; - int i, half, my_count; - double this_val, min_val, div_const, x_med, this_wt; - double *x, *abs_x_dev, *wt, *wtx; + int i, half, my_count, n; + size_t nlong; + double C_val, this_val, min_val, div_const, x_med, this_wt; + double *x2, *abs_x_dev, *wt, *wtx, *x_p; listnode tmp; - int n = *n_ptr; - double C = *C_ptr; + nlong = dplRlength(x); + /* Long vectors not supported (limitation of rPsort) */ + if (nlong > INT_MAX) { + error(_("long vectors not supported")); + } + C2 = PROTECT(coerceVector(C, REALSXP)); + if (length(C2) != 1) { + UNPROTECT(1); + error(_("length of 'C' must be 1")); + } + C_val = REAL(C2)[0]; + UNPROTECT(1); + n = (int) nlong; + ans = PROTECT(allocVector(REALSXP, 1)); /* Avoid complexity and possible crash in case of empty input * vector */ if(n == 0){ - *result = R_NaN; - return; + REAL(ans)[0] = R_NaN; + UNPROTECT(1); + return ans; } + /* Note: x must be a numeric vector */ + x_p = REAL(x); - /* x is a copy of the argument array x_const (the data) */ - x = (double *) R_alloc(n, sizeof(double)); + /* x2 is a copy of the data part of argument x */ + x2 = (double *) R_alloc(n, sizeof(double)); for(i = 0; i < n; i++) - x[i] = x_const[i]; + x2[i] = x_p[i]; /* Median of x */ if((n & 0x1) == 1){ /* n is odd */ half = ((unsigned int)n) >> 1; - rPsort(x, n, half); /* Partial sort: */ - x_med = x[half]; /* element at position half is correct.*/ + rPsort(x2, n, half); /* Partial sort: */ + x_med = x2[half]; /* element at position half is correct.*/ n_odd = TRUE; } else { /* n is even */ half = ((unsigned int)n) >> 1; - rPsort(x, n, half-1); /* Elements at positions half-1 */ - min_val = x[half]; + rPsort(x2, n, half-1); /* Elements at positions half-1 */ + min_val = x2[half]; for(i = half+1; i < n; i++){/* and half */ - this_val = x[i]; /* (minimum in the */ + this_val = x2[i]; /* (minimum in the */ if(this_val < min_val) /* "larger than" side) */ min_val = this_val; } - x_med = (x[half-1]+min_val)/2.0f; + x_med = (x2[half-1]+min_val)/2.0f; n_odd = FALSE; } /* abs(x - median(x)) */ abs_x_dev = (double *) R_alloc(n, sizeof(double)); for(i = 0; i < n; i++){ - this_val = x[i]-x_med; + this_val = x2[i]-x_med; abs_x_dev[i] = this_val<0 ? -this_val : this_val; } @@ -77,24 +91,24 @@ } div_const = (abs_x_dev[half-1]+min_val)/2.0f; } - /* This is a normalization constant (well, constant over x[i]) */ - div_const = div_const * C + 1e-6; + /* This is a normalization constant (well, constant over x2[i]) */ + div_const = div_const * C_val + 1e-6; - /* Number of values x[i] with non-zero weights */ + /* Number of values x2[i] with non-zero weights */ my_count = 0; /* Recycling memory, i.e. renaming the same space */ wt = abs_x_dev; - wtx = x; /* Have to be careful not to overwrite too soon */ + wtx = x2; /* Have to be careful not to overwrite too soon */ /* Weights (wt) and weighted data (wtx) */ for(i = 0; i < n; i++){ - this_wt = (x[i]-x_med) / div_const; + this_wt = (x2[i]-x_med) / div_const; if(this_wt >= -1.0f && this_wt <= 1.0f){ /* absolute value <= 1 */ this_wt = 1.0f - this_wt * this_wt; this_wt *= this_wt; wt[my_count] = this_wt; - wtx[my_count++] = this_wt * x[i]; + wtx[my_count++] = this_wt * x2[i]; } } @@ -102,14 +116,15 @@ Sum of my_count values. No more, no less. The tails of the arrays are now garbage, not harmlessly zero. */ if(my_count == 1){ /* Avoid call to sum function in border case */ - *result = wtx[0] / wt[0]; + REAL(ans)[0] = wtx[0] / wt[0]; } else if(my_count > 0){ /* Setup for msum. */ tmp.next = NULL; /* Not the usual 'sum of data divided by sum of ones' */ - *result = msum(wtx, my_count, &tmp) / msum(wt, my_count, &tmp); + REAL(ans)[0] = msum(wtx, my_count, &tmp) / msum(wt, my_count, &tmp); } else{ /* Nothing to sum */ - *result = R_NaN; + REAL(ans)[0] = R_NaN; } - return; + UNPROTECT(1); + return ans; }