From noreply at r-forge.r-project.org  Mon Oct 28 19:32:07 2013
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Mon, 28 Oct 2013 19:32:07 +0100 (CET)
Subject: [Xts-commits] r793 - in pkg/xts: R src
Message-ID: <20131028183207.6DB10185A47@r-forge.r-project.org>

Author: bodanker
Date: 2013-10-28 19:32:07 +0100 (Mon, 28 Oct 2013)
New Revision: 793

Modified:
   pkg/xts/R/na.R
   pkg/xts/src/leadingNA.c
Log:
- add experimental .na.locf.xts function that operates on all columns


Modified: pkg/xts/R/na.R
===================================================================
--- pkg/xts/R/na.R	2013-09-19 12:00:40 UTC (rev 792)
+++ pkg/xts/R/na.R	2013-10-28 18:32:07 UTC (rev 793)
@@ -110,3 +110,14 @@
       return(structure(na.omit(x),na.action=NULL))
     } else x
 }
+
+.na.locf.xts <- function(object, na.rm=FALSE, fromLast=FALSE, maxgap=Inf, ...) {
+    stopifnot(is.xts(object))
+    maxgap <- min(maxgap, NROW(object))
+    if(length(object) == 0)
+      return(object)
+    x <- .Call("na_locf_col", object, fromLast, maxgap, Inf, PACKAGE="xts")
+    if(na.rm) {
+      return(structure(na.omit(x),na.action=NULL))
+    } else x
+}

Modified: pkg/xts/src/leadingNA.c
===================================================================
--- pkg/xts/src/leadingNA.c	2013-09-19 12:00:40 UTC (rev 792)
+++ pkg/xts/src/leadingNA.c	2013-10-28 18:32:07 UTC (rev 793)
@@ -68,6 +68,52 @@
   return(i);
 }
 
+int firstNonNACol (SEXP x, int col)
+{
+  /*
+    Internal use only; called by naCheck below.
+  */
+
+  int i=0, nr;
+  int *int_x=NULL;
+  double *real_x=NULL;
+
+  nr = nrows(x);
+  if(col > ncols(x)-1 || col < 0L)
+      error("column out of range");
+
+  switch(TYPEOF(x)) {
+    case LGLSXP:
+      int_x = LOGICAL(x);
+      for(i=0+col*nr; i<(nr+col*nr); i++) {
+        if(int_x[i]!=NA_LOGICAL) {
+          break;
+        }
+      }
+      break;
+    case INTSXP:
+      int_x = INTEGER(x);
+      for(i=0+col*nr; i<(nr+col*nr); i++) {
+        if(int_x[i]!=NA_INTEGER) {
+          break;
+        }
+      }
+      break;
+    case REALSXP:
+      real_x = REAL(x);
+      for(i=0+col*nr; i<(nr+col*nr); i++) {
+        if(!ISNA(real_x[i]) && !ISNAN(real_x[i])) {
+          break;
+        }
+      }
+      break;
+    default:
+      error("unsupported type");
+      break;
+  }
+  return(i);
+}
+
 SEXP naCheck (SEXP x, SEXP check)
 {
   /*
@@ -307,6 +353,203 @@
   return(result);
 }
 
+SEXP na_locf_col (SEXP x, SEXP fromLast, SEXP _maxgap, SEXP _limit)
+{
+  /* version of na_locf that works on multivariate data
+   * of type LGLSXP, INTSXP and REALSXP.   */
+  SEXP result;
+
+  int i, ii, j, nr, nc, _first=0, P=0;
+  double gap, maxgap, limit;
+
+  int *int_x=NULL, *int_result=NULL;
+  double *real_x=NULL, *real_result=NULL;
+
+  nr = nrows(x);
+  nc = ncols(x);
+  maxgap = asReal(_maxgap);
+  limit  = asReal(_limit);
+  gap = 0;
+
+  if(firstNonNA(x) == nr)
+    return(x);
+
+  PROTECT(result = allocMatrix(TYPEOF(x), nr, nc)); P++;
+
+  switch(TYPEOF(x)) {
+    case LGLSXP:
+      int_x = LOGICAL(x);
+      int_result = LOGICAL(result);
+      if(!LOGICAL(fromLast)[0]) {
+        for(j=0; j < nc; j++) {
+          /* copy leading NAs */
+          _first = firstNonNACol(x, j);
+          //if(_first+1 == nr) continue;
+          for(i=0+j*nr; i < (_first+1); i++) {
+            int_result[i] = int_x[i];
+          }
+          /* result[_first] now has first value fromLast=FALSE */
+          for(i=_first+1; i<nr+j*nr; i++) {
+            int_result[i] = int_x[i];
+            if(int_result[i] == NA_LOGICAL && gap < maxgap) {
+              int_result[i] = int_result[i-1];
+              gap++;
+            }
+          }
+          if((int)gap > (int)maxgap) {  /* check that we don't have excessive trailing gap */
+            for(ii = i-1; ii > i-gap-1; ii--) {
+              int_result[ii] = NA_LOGICAL; 
+            }
+          }
+        }
+      } else {
+        /* nr-2 is first position to fill fromLast=TRUE */
+        for(j=0; j < nc; j++) {
+          int_result[nr-1+j*nr] = int_x[nr-1+j*nr];
+          for(i=nr-2 + j*nr; i>=0+j*nr; i--) {
+            int_result[i] = int_x[i];
+            if(int_result[i] == NA_LOGICAL && gap < maxgap) {
+              int_result[i] = int_result[i+1];
+              gap++;
+            }
+          }
+        }
+      }
+      break;
+    case INTSXP:
+      int_x = INTEGER(x);
+      int_result = INTEGER(result);
+      if(!LOGICAL(fromLast)[0]) {
+        for(j=0; j < nc; j++) {
+          /* copy leading NAs */
+          _first = firstNonNACol(x, j);
+          //if(_first+1 == nr) continue;
+          for(i=0+j*nr; i < (_first+1); i++) {
+            int_result[i] = int_x[i];
+          }
+          /* result[_first] now has first value fromLast=FALSE */
+          for(i=_first+1; i<nr+j*nr; i++) {
+            int_result[i] = int_x[i];
+            if(int_result[i] == NA_INTEGER) {
+              if(limit > gap)
+                int_result[i] = int_result[i-1];
+              gap++;
+            } else {
+              if((int)gap > (int)maxgap) {
+                for(ii = i-1; ii > i-gap-1; ii--) {
+                  int_result[ii] = NA_INTEGER; 
+                }
+              }
+              gap=0;
+            }
+          }
+          if((int)gap > (int)maxgap) {  /* check that we don't have excessive trailing gap */
+            for(ii = i-1; ii > i-gap-1; ii--) {
+              int_result[ii] = NA_INTEGER; 
+            }
+          }
+        }
+      } else {
+        /* nr-2 is first position to fill fromLast=TRUE */
+        for(j=0; j < nc; j++) {
+          int_result[nr-1+j*nr] = int_x[nr-1+j*nr];
+          for(i=nr-2 + j*nr; i>=0+j*nr; i--) {
+            int_result[i] = int_x[i];
+            if(int_result[i] == NA_INTEGER) {
+              if(limit > gap)
+                int_result[i] = int_result[i+1];
+              gap++;
+            } else {
+              if((int)gap > (int)maxgap) {
+                for(ii = i+1; ii < i+gap+1; ii++) {
+                  int_result[ii] = NA_INTEGER; 
+                }
+              }
+              gap=0;
+            }
+          }
+          if((int)gap > (int)maxgap) {  /* check that we don't have leading trailing gap */
+            for(ii = i+1; ii < i+gap+1; ii++) {
+              int_result[ii] = NA_INTEGER; 
+            }
+          }
+        }
+      }
+      break;
+    case REALSXP:
+      real_x = REAL(x);
+      real_result = REAL(result);
+      if(!LOGICAL(fromLast)[0]) {   /* fromLast=FALSE */
+        for(j=0; j < nc; j++) {
+          /* copy leading NAs */
+          _first = firstNonNACol(x, j);
+          //if(_first+1 == nr) continue;
+          for(i=0+j*nr; i < (_first+1); i++) {
+            real_result[i] = real_x[i];
+          }
+          /* result[_first] now has first value fromLast=FALSE */
+          for(i=_first+1; i<nr+j*nr; i++) {
+            real_result[i] = real_x[i];
+            if( ISNA(real_result[i]) || ISNAN(real_result[i])) {
+              if(limit > gap)
+                real_result[i] = real_result[i-1];
+              gap++;
+            } else {
+              if((int)gap > (int)maxgap) {
+                for(ii = i-1; ii > i-gap-1; ii--) {
+                  real_result[ii] = NA_REAL; 
+                }
+              }
+              gap=0;
+            }
+          }
+          if((int)gap > (int)maxgap) {  /* check that we don't have excessive trailing gap */
+            for(ii = i-1; ii > i-gap-1; ii--) {
+              real_result[ii] = NA_REAL; 
+            }
+          }
+        }
+      } else {                      /* fromLast=TRUE */
+        for(j=0; j < nc; j++) {
+          real_result[nr-1+j*nr] = int_x[nr-1+j*nr];
+          for(i=nr-2 + j*nr; i>=0+j*nr; i--) {
+            real_result[i] = real_x[i];
+            if(ISNA(real_result[i]) || ISNAN(real_result[i])) {
+              if(limit > gap)
+                real_result[i] = real_result[i+1];
+              gap++;
+            } else {
+              if((int)gap > (int)maxgap) {
+                for(ii = i+1; ii < i+gap+1; ii++) {
+                  real_result[ii] = NA_REAL; 
+                }
+              }
+              gap=0;
+            }
+          }
+          if((int)gap > (int)maxgap) {  /* check that we don't have leading trailing gap */
+            for(ii = i+1; ii < i+gap+1; ii++) {
+              real_result[ii] = NA_REAL; 
+            }
+          }
+        }
+      }
+      break;
+    default:
+      error("unsupported type");
+      break;
+  }
+  if(isXts(x)) {
+    setAttrib(result, R_DimSymbol, getAttrib(x, R_DimSymbol));
+    setAttrib(result, R_DimNamesSymbol, getAttrib(x, R_DimNamesSymbol));
+    setAttrib(result, xts_IndexSymbol, getAttrib(x, xts_IndexSymbol));
+    copy_xtsCoreAttributes(x, result);
+    copy_xtsAttributes(x, result);
+  }
+  UNPROTECT(P);
+  return(result);
+}
+
 SEXP na_omit_xts (SEXP x)
 {
   SEXP na_index, not_na_index, col_index, result;


From noreply at r-forge.r-project.org  Thu Oct 31 20:54:30 2013
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Thu, 31 Oct 2013 20:54:30 +0100 (CET)
Subject: [Xts-commits] r794 - pkg/xts/src
Message-ID: <20131031195430.4540618514E@r-forge.r-project.org>

Author: bodanker
Date: 2013-10-31 20:54:29 +0100 (Thu, 31 Oct 2013)
New Revision: 794

Modified:
   pkg/xts/src/leadingNA.c
Log:
- fix copy/paste error that caused segfault


Modified: pkg/xts/src/leadingNA.c
===================================================================
--- pkg/xts/src/leadingNA.c	2013-10-28 18:32:07 UTC (rev 793)
+++ pkg/xts/src/leadingNA.c	2013-10-31 19:54:29 UTC (rev 794)
@@ -511,7 +511,7 @@
         }
       } else {                      /* fromLast=TRUE */
         for(j=0; j < nc; j++) {
-          real_result[nr-1+j*nr] = int_x[nr-1+j*nr];
+          real_result[nr-1+j*nr] = real_x[nr-1+j*nr];
           for(i=nr-2 + j*nr; i>=0+j*nr; i--) {
             real_result[i] = real_x[i];
             if(ISNA(real_result[i]) || ISNAN(real_result[i])) {


From noreply at r-forge.r-project.org  Thu Oct 31 22:36:29 2013
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Thu, 31 Oct 2013 22:36:29 +0100 (CET)
Subject: [Xts-commits] r795 - pkg/xts/R
Message-ID: <20131031213629.3DB831862CD@r-forge.r-project.org>

Author: bodanker
Date: 2013-10-31 22:36:28 +0100 (Thu, 31 Oct 2013)
New Revision: 795

Modified:
   pkg/xts/R/dimnames.R
Log:
- add PACKAGE arg to .Call


Modified: pkg/xts/R/dimnames.R
===================================================================
--- pkg/xts/R/dimnames.R	2013-10-31 19:54:29 UTC (rev 794)
+++ pkg/xts/R/dimnames.R	2013-10-31 21:36:28 UTC (rev 795)
@@ -25,7 +25,7 @@
 `dimnames.xts` <-
 function(x) {
   #list(NULL, colnames(unclass(x)))
-  .Call("dimnames_zoo",x);
+  .Call("dimnames_zoo",x,PACKAGE="xts");
   #list(as.character(index(x)), colnames(unclass(x)))
 }