[Xts-commits] r636 - in pkg/xts: R src

[noreply at r-forge.r-project.org]

Author: bodanker
Date: 2012-06-18 03:32:41 +0200 (Mon, 18 Jun 2012)
New Revision: 636

Modified:
   pkg/xts/R/rollapply.xts.R
   pkg/xts/src/rollfun.c
Log:
- Initial commit of some R-level roll* functionality
- Check there are > n non-NA values
- Coerce roll_cov inputs to REAL


Modified: pkg/xts/R/rollapply.xts.R
===================================================================
--- pkg/xts/R/rollapply.xts.R	2012-06-17 17:03:41 UTC (rev 635)
+++ pkg/xts/R/rollapply.xts.R	2012-06-18 01:32:41 UTC (rev 636)
@@ -109,3 +109,97 @@
   return(res)
 } 
 
+rollsum.xts <- function (x, k, fill=if(na.pad) NA, na.pad=TRUE,
+  align=c("right", "center", "left"), ...) {
+  ## FIXME: align and fill are not respected!
+
+  # from rollapply.xts; is this necessary?
+  x <- try.xts(x)
+
+  # from rollmean.zoo
+  if (!missing(na.pad))
+    warning("na.pad is deprecated. Use fill.")
+
+  # process alignment
+  align <- match.arg(align)
+  n1 <- switch(align,    
+    "left" = { k - 1 },
+    "center" = { floor(k/2) },
+    "right" = { 0 })
+  #ix <- index(x)[seq((k-n1), (nrow(x)-n1), 1)]
+  res <- .Call("roll_sum", x, k, PACKAGE="xts")
+  res
+}
+
+rollmean.xts <- function (x, k, fill=if(na.pad) NA, na.pad=TRUE,
+  align=c("right", "center", "left"), ...) {
+  rollsum.xts(x=x, k=k, fill=fill, align=align, ...) / k
+}
+
+rollmax.xts <- function (x, k, fill=if(na.pad) NA, na.pad=TRUE,
+  align=c("right", "center", "left"), ...) {
+  ## FIXME: align and fill are not respected!
+
+  # from rollapply.xts; is this necessary?
+  x <- try.xts(x)
+
+  # from rollmean.zoo
+  if (!missing(na.pad))
+    warning("na.pad is deprecated. Use fill.")
+
+  # process alignment
+  align <- match.arg(align)
+  n1 <- switch(align,    
+    "left" = { k - 1 },
+    "center" = { floor(k/2) },
+    "right" = { 0 })
+  #ix <- index(x)[seq((k-n1), (nrow(x)-n1), 1)]
+  res <- .Call("roll_max", x, k, PACKAGE="xts")
+  res
+}
+
+rollmin.xts <- function (x, k, fill=if(na.pad) NA, na.pad=TRUE,
+  align=c("right", "center", "left"), ...) {
+  ## FIXME: align and fill are not respected!
+
+  # from rollapply.xts; is this necessary?
+  x <- try.xts(x)
+
+  # from rollmean.zoo
+  if (!missing(na.pad))
+    warning("na.pad is deprecated. Use fill.")
+
+  # process alignment
+  align <- match.arg(align)
+  n1 <- switch(align,    
+    "left" = { k - 1 },
+    "center" = { floor(k/2) },
+    "right" = { 0 })
+  #ix <- index(x)[seq((k-n1), (nrow(x)-n1), 1)]
+  res <- .Call("roll_min", x, k, PACKAGE="xts")
+  res
+}
+
+rollcov.xts <- function (x, y, k, fill=if(na.pad) NA, na.pad=TRUE,
+  align=c("right", "center", "left"), sample=TRUE, ...) {
+  ## FIXME: align and fill are not respected!
+
+  # from rollapply.xts; is this necessary?
+  x <- try.xts(x)
+  y <- try.xts(y)
+
+  # from rollmean.zoo
+  if (!missing(na.pad))
+    warning("na.pad is deprecated. Use fill.")
+
+  # process alignment
+  align <- match.arg(align)
+  n1 <- switch(align,    
+    "left" = { k - 1 },
+    "center" = { floor(k/2) },
+    "right" = { 0 })
+  #ix <- index(x)[seq((k-n1), (nrow(x)-n1), 1)]
+  res <- .Call("roll_cov", x, y, k, sample, PACKAGE="xts")
+  res
+}
+

Modified: pkg/xts/src/rollfun.c
===================================================================
--- pkg/xts/src/rollfun.c	2012-06-17 17:03:41 UTC (rev 635)
+++ pkg/xts/src/rollfun.c	2012-06-18 01:32:41 UTC (rev 636)
@@ -44,6 +44,8 @@
   SEXP first;
   PROTECT(first = naCheck(x, ScalarLogical(TRUE))); P++;
   int int_first = asInteger(first);
+  if(int_n + int_first > nrs)
+    error("not enough non-NA values");
 
   switch(TYPEOF(x)) {
     case REALSXP:
@@ -80,7 +82,7 @@
       break;
     /*
     case STRSXP:  fail!
-    case LGLSXP:  convert to int??
+    case LGLSXP:  convert to int, like sum, cumsum, etc?
     case CPLXSXP:
     */
     default:
@@ -119,7 +121,9 @@
   /* check for non-leading NAs and get first non-NA location */
   SEXP first;
   PROTECT(first = naCheck(x, ScalarLogical(TRUE))); P++;
-  int int_first = INTEGER(first)[0];
+  int int_first = asInteger(first);
+  if(int_n + int_first > nrs)
+    error("not enough non-NA values");
 
   /* The branch by type allows for fewer type checks/branching
    * within the algorithm, providing a _much_ faster mechanism
@@ -248,6 +252,8 @@
   SEXP first;
   PROTECT(first = naCheck(x, ScalarLogical(TRUE))); P++;
   int int_first = asInteger(first);
+  if(int_n + int_first > nrs)
+    error("not enough non-NA values");
 
   /* The branch by type allows for fewer type checks/branching
    * within the algorithm, providing a _much_ faster mechanism
@@ -363,6 +369,10 @@
   int nry = nrows(y);
   if(nrx != nry) error("nrx != nry, blame the R function writer");
 
+  /* Coerce to REALSXP to ensure roll_sum returns REALSXP */
+  PROTECT(x = coerceVector(x, REALSXP)); P++;
+  PROTECT(y = coerceVector(y, REALSXP)); P++;
+
   /* Get values from function arguments */
   double *real_x = REAL(PROTECT(coerceVector(x, REALSXP))); P++;
   double *real_y = REAL(PROTECT(coerceVector(y, REALSXP))); P++;
@@ -394,6 +404,8 @@
   SEXP first;
   PROTECT(first = naCheck(sum_xy, ScalarLogical(TRUE))); P++;
   int int_first = asInteger(first);
+  if(int_n + int_first > nrx)
+    error("not enough non-NA values");
 
   /* set leading NAs */
   for(i=0; i<int_first; i++) {
@@ -428,9 +440,3 @@
 }
 */
 
-/*
-SEXP do_runsum (SEXP x, SEXP n, SEXP result)
-{
-
-}
-*/