[Dplr-commits] r1027 - in pkg/dplR: . R man

Thu Jun 9 01:19:00 CEST 2016

Author: andybunn
Date: 2016-06-09 01:19:00 +0200 (Thu, 09 Jun 2016)
New Revision: 1027

Added:
   pkg/dplR/R/rwl.report.R
   pkg/dplR/man/rwl.report.Rd
Modified:
   pkg/dplR/ChangeLog
   pkg/dplR/NAMESPACE
   pkg/dplR/R/helpers.R
Log:
rwl.report is a new function to provide a summary of information about an rwl object. This is still very much a work in progress.

Modified: pkg/dplR/ChangeLog
===================================================================

--- pkg/dplR/ChangeLog	2016-06-06 10:05:16 UTC (rev 1026)
+++ pkg/dplR/ChangeLog	2016-06-08 23:19:00 UTC (rev 1027)
@@ -5,6 +5,27 @@
 
 - Added Friedman under method argument in the help file. It was ommitted by mistake. 
 
+File: helpers.R
+-----------------
+
+- Added function find.internal.na() that reutrns the index of internal NA in a series. This will be used by the rwl.report() function and could be used (maybe) by the fill.internal.NA
+
+File: rwl.report.R
+-----------------
+
+- Added function find.internal.na() that reutrns the index of internal NA in a series. This will be used by the ringReport() function and could be used (maybe) by the fill.internal.NA
+
+File: NAMESPACE
+-----------------
+
+- Added rwl.report to export
+
+File: sea.R
+-----------------
+
+- Note on commit from Zang: sea() simplified and computation of p-values fixed; computation of p-values and CI bands for sea() now based on ecdf() and quantile() functions.
+
+
 * CHANGES IN dplR VERSION 1.6.4
 
 File: DESCRIPTION

Modified: pkg/dplR/NAMESPACE
===================================================================
--- pkg/dplR/NAMESPACE	2016-06-06 10:05:16 UTC (rev 1026)
+++ pkg/dplR/NAMESPACE	2016-06-08 23:19:00 UTC (rev 1027)
@@ -39,6 +39,8 @@
 
 importFrom(XML, xmlEventParse)
 
+importFrom(plyr, alply)
+
 export(autoread.ids, bai.in, bai.out, ccf.series.rwl, chron, cms,
        combine.rwl, common.interval, corr.rwl.seg, corr.series.seg,
        crn.plot, detrend, detrend.series, ffcsaps, fill.internal.NA,
@@ -52,9 +54,10 @@
        write.compact, write.crn, write.rwl, write.tridas,
        write.tucson, plot.rwl, interseries.cor, summary.rwl,
        plot.crn, insert.ring, delete.ring, xskel.ccf.plot, xskel.plot,
-       latexify, latexDate, rasterPlot, treeMean)
+       latexify, latexDate, rasterPlot, treeMean, rwl.report, print.rwl.report)
 
 S3method(print, redfit)
 S3method(plot, rwl)
 S3method(plot, crn)
 S3method(summary, rwl)
+S3method(print, rwl.report)

Modified: pkg/dplR/R/helpers.R
===================================================================
--- pkg/dplR/R/helpers.R	2016-06-06 10:05:16 UTC (rev 1026)
+++ pkg/dplR/R/helpers.R	2016-06-08 23:19:00 UTC (rev 1027)
@@ -398,3 +398,28 @@
     }
     y
 }
+
+
+# Looks for internal NA in a series. Returns the position of internal NA via which
+find.internal.na <- function(x) {
+  x.na <- is.na(x)
+  x.ok <- which(!x.na)
+  n.ok <- length(x.ok)
+  if (n.ok <= 1) {
+    internal.na <- 0 # NA, NULL?
+    return(internal.na)
+  }
+  
+  first.ok <- x.ok[1]
+  last.ok <- x.ok[n.ok]
+  
+  if (last.ok - first.ok + 1 > n.ok) {
+    first.to.last <- first.ok:last.ok
+    x.notok <- which(x.na)
+    internal.na <- x.notok[x.notok %in% first.to.last]
+  }
+  else {
+    internal.na <- 0 # NA, NULL?
+  }
+  internal.na    
+}

Added: pkg/dplR/R/rwl.report.R
===================================================================
--- pkg/dplR/R/rwl.report.R	                        (rev 0)
+++ pkg/dplR/R/rwl.report.R	2016-06-08 23:19:00 UTC (rev 1027)
@@ -0,0 +1,78 @@
+rwl.report <- function(rwl){
+  oldw <- getOption("warn")
+  options(warn = -1)
+  
+  res <- list()
+  # get a summary
+  res$sum <- summary.rwl(rwl)
+  
+  # interseries
+  res$rbar <- interseries.cor(rwl)
+  
+  # missing rings
+  zeds <- rwl == 0
+  zeds <- apply(zeds,2,which)
+  zeds <- sapply(zeds, function(x) {as.numeric(names(x))} )
+  zeds <- zeds[lapply(zeds,length)>0]
+  if(length(zeds)<1) res$zeros <- numeric(0)
+  else res$zeros <- zeds
+  
+  # internal NA
+  internalNAs <- alply(rwl, 2, find.internal.na) # like apply but forces a list
+  names(internalNAs) <- names(rwl)
+  internalNAs <- sapply(internalNAs, function(x) {as.numeric(rownames(rwl)[x])} )
+  internalNAs <- internalNAs[lapply(internalNAs,length)>0]
+  if(length(internalNAs)<1) res$internalNAs <- numeric(0)
+  else res$internalNAs <- internalNAs
+
+  # wee rings
+  wee <- rwl > 0 & rwl < 0.003
+  wee <- apply(wee,2,which)
+  res$wee <- sapply(wee, function(x) {as.numeric(names(x))} )
+  
+  options(warn = oldw)
+  
+  class(res) <- "rwl.report"
+  res  
+}
+
+print.rwl.report <- function(x){
+  cat("Number of dated series:",nrow(x$sum),"\n")
+  cat("Avg series length:",mean(x$sum$year),"\n")
+  cat("Span: ",min(x$sum$first), "-", max(x$sum$last), "\n")
+  cat("Avg series intercorrelation:",mean(x$rbar[,1]), "\n")
+  cat("-------------\n")
+  cat("Absent rings listed by series \n")
+  if(length(x$zeros)==0) cat("    None \n")
+  else{
+    for(i in 1:length(x$zeros)){
+      tmp = x$zeros[[i]]
+      if(length(tmp)==0) next()
+      cat("    Series", names(x$zeros)[i],"--",tmp,"\n",  
+          sep = " ")
+    }
+  }
+  cat("-------------\n")
+  cat("Internal NA values listed by series \n")
+  if(length(x$internalNAs)==0) cat("    None \n")
+  else{
+    for(i in 1:length(x$internalNAs)){
+      tmp = x$internalNAs[[i]]
+      if(length(tmp)==0) next()
+      cat("    Series", names(x$internalNAs)[i],"--",tmp,"\n",  
+          sep = " ")
+    }
+  }
+  cat("-------------\n")
+  cat("Very small rings listed by series \n")
+  if(length(x$wee)==0) cat("    None \n")
+  else{
+    for(i in 1:length(x$wee)){
+      tmp = x$wee[[i]]
+      if(length(tmp)==0) next()
+      cat("Series", names(x$wee)[i],"--",tmp,"\n",  
+          sep = " ")
+    }
+  }
+  invisible(x)
+}

Added: pkg/dplR/man/rwl.report.Rd
===================================================================
--- pkg/dplR/man/rwl.report.Rd	                        (rev 0)
+++ pkg/dplR/man/rwl.report.Rd	2016-06-08 23:19:00 UTC (rev 1027)
@@ -0,0 +1,36 @@
+\encoding{UTF-8}
+\name{rwl.report}
+\alias{rwl.report}
+\title{Do some reporting on a RWL object}
+\description{
+  This function...
+}
+\usage{
+rwl.report(x)
+}
+\arguments{
+  \item{x}{a \code{data.frame} of ring widths with
+    \code{rownames(\var{x})} containing years and \code{colnames(x)}
+    containing each series \acronym{ID} such as produced by
+    \code{\link{read.rwl}}}
+}
+\details{
+  This...
+}
+\value{
+  A \code{list} with...
+}
+\author{ Andy Bunn.  Patched and improved by Mikko Korpela. }
+\seealso{ \code{\link{read.rwl}}, \code{\link{summary.rwl}}
+}
+\examples{
+data("gp.rwl")
+rwl.report(gp.rwl)
+foo <- gp.rwl
+foo[177,1] <- NA 
+foo[177:180,3] <- NA 
+rwl.report(foo)
+x <- rwl.report(foo)
+x
+}
+\keyword{ manip }

