[Xts-commits] r793 - in pkg/xts: R src
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mon Oct 28 19:32:07 CET 2013
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;
More information about the Xts-commits
mailing list