search

joshuaulrich / xts

Extensible time series class that provides uniform handling of many R time series classes by extending zoo.
http://joshuaulrich.github.io/xts/
GNU General Public License v2.0
219 stars 71 forks source link

Make C API subsetting consistent with R API #184

Open joshuaulrich opened 7 years ago

joshuaulrich commented 7 years ago

The grep output below shows that the R API uses the _do_subset_xts function, but the older do_subset_xts function is still exposed in the API. The na_omit_xts function also calls the older do_subset_xts.

Currently only RcppXts and TTR link to xts, so need to check that the switch doesn't break anything.

josh@thinkpad: ~/git/xts (master)
> grep do_subset -r *
inst/include/xts.h:SEXP do_subset_xts(SEXP x, SEXP sr, SEXP sc, SEXP drop);
R/xts.methods.R:  .Call('_do_subset_xts', x, i, j, FALSE, PACKAGE='xts')
R/xts.methods.R:          return(.Call('_do_subset_xts', 
R/xts.methods.R:    return(.Call('_do_subset_xts', x, as.integer(i), as.integer(j), drop, PACKAGE='xts'))
src/leadingNA.c:  PROTECT(result = do_subset_xts(x, not_na_index, col_index, ScalarLogical(0)));
src/subset.c:SEXP _do_subset_xts (SEXP x, SEXP sr, SEXP sc, SEXP drop) {
src/subset.old.c:SEXP do_subset_xts(SEXP x, SEXP sr, SEXP sc, SEXP drop) //SEXP s, SEXP call, int drop)
src/init.c:  {"do_subset_xts",         (DL_FUNC) &do_subset_xts,           4},
ghost commented 7 years ago 
diff -urN xts.orig/R/xts.methods.R xts/R/xts.methods.R
--- xts.orig/R/xts.methods.R    2017-05-29 12:18:10.000000000 +0200
+++ xts/R/xts.methods.R 2017-05-29 12:19:52.000000000 +0200
@@ -25,7 +25,7 @@
   if(missing(j)) {
     j <- 1:NCOL(x)
   }
-  .Call('_do_subset_xts', x, i, j, FALSE, PACKAGE='xts')
+  .Call('do_subset_xts', x, i, j, FALSE, PACKAGE='xts')
 }

 `.subset.xts` <- `[.xts` <-
@@ -137,7 +137,7 @@
                        drop,
                        as.integer(i[1]), as.integer(i[length(i)]), PACKAGE="xts"))
         } else {
-          return(.Call('_do_subset_xts', 
+          return(.Call('do_subset_xts', 
                        x, as.integer(i),
                        as.integer(1:nc), 
                        drop, PACKAGE='xts'))
@@ -186,7 +186,7 @@
                        drop,
                        as.integer(i[1]), as.integer(i[length(i)]), PACKAGE='xts'))
     } else
-    return(.Call('_do_subset_xts', x, as.integer(i), as.integer(j), drop, PACKAGE='xts'))
+    return(.Call('do_subset_xts', x, as.integer(i), as.integer(j), drop, PACKAGE='xts'))
 }

 # Replacement method for xts objects
diff -urN xts.orig/src/subset.c xts/src/subset.c
--- xts.orig/src/subset.c   2017-05-29 12:18:10.000000000 +0200
+++ xts/src/subset.c    2017-05-29 12:28:11.000000000 +0200
@@ -91,7 +91,7 @@
     return result;
 }

-SEXP _do_subset_xts (SEXP x, SEXP sr, SEXP sc, SEXP drop) {
+SEXP do_subset_xts (SEXP x, SEXP sr, SEXP sc, SEXP drop) {
   SEXP result;
   int i, j, nr, nc, nrs, ncs;
   int P=0;
@@ -435,3 +435,7 @@
   return result;
 }

+SEXP _do_subset_xts (SEXP x, SEXP sr, SEXP sc, SEXP drop)
+{
+  return do_subset_xts (x, sr, sc, drop);
+}
diff -urN xts.orig/src/subset.old.c xts/src/subset.old.c
--- xts.orig/src/subset.old.c   2017-05-29 12:18:10.000000000 +0200
+++ xts/src/subset.old.c    1970-01-01 01:00:00.000000000 +0100
@@ -1,310 +0,0 @@
-/*
-#   xts: eXtensible time-series 
-#
-#   Copyright (C) 2008  Jeffrey A. Ryan jeff.a.ryan @ gmail.com
-#
-#   Contributions from Joshua M. Ulrich
-#
-#   This program is free software: you can redistribute it and/or modify
-#   it under the terms of the GNU General Public License as published by
-#   the Free Software Foundation, either version 3 of the License, or
-#   (at your option) any later version.
-#
-#   This program is distributed in the hope that it will be useful,
-#   but WITHOUT ANY WARRANTY; without even the implied warranty of
-#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-#   GNU General Public License for more details.
-#
-#   You should have received a copy of the GNU General Public License
-#   along with this program.  If not, see <http://www.gnu.org/licenses/>.
-*/
-
-
-/*
-Base code borrowed from R's main/src/subset.c to see how to create a function to subset
-an xts object in it's entirety
-
-All modification are by Jeffrey A. Ryan 2008
-*/
-
-#include <R.h>
-#include <Rdefines.h>
-#include <Rinternals.h>
-#include "xts.h"
-// xtsExtractSubset {{{
-static SEXP xtsExtractSubset(SEXP x, SEXP result, SEXP indx) //, SEXP call)
-{
-    int i, ii, n, nx, mode;
-    SEXP tmp, tmp2;
-    mode = TYPEOF(x);
-    n = LENGTH(indx);
-    nx = length(x);
-    tmp = result;
-
-    if (x == R_NilValue)
-    return x;
-
-    for (i = 0; i < n; i++) {
-    ii = INTEGER(indx)[i];
-    if (ii != NA_INTEGER)
-        ii--;
-    switch (mode) {
-    case LGLSXP:
-        if (0 <= ii && ii < nx && ii != NA_LOGICAL)
-        LOGICAL(result)[i] = LOGICAL(x)[ii];
-        else
-        LOGICAL(result)[i] = NA_LOGICAL;
-        break;
-    case INTSXP:
-        if (0 <= ii && ii < nx && ii != NA_INTEGER)
-        INTEGER(result)[i] = INTEGER(x)[ii];
-        else
-        INTEGER(result)[i] = NA_INTEGER;
-        break;
-    case REALSXP:
-        if (0 <= ii && ii < nx && ii != NA_INTEGER)
-        REAL(result)[i] = REAL(x)[ii];
-        else
-        REAL(result)[i] = NA_REAL;
-        break;
-    case CPLXSXP:
-        if (0 <= ii && ii < nx && ii != NA_INTEGER) {
-        COMPLEX(result)[i] = COMPLEX(x)[ii];
-        }
-        else {
-        COMPLEX(result)[i].r = NA_REAL;
-        COMPLEX(result)[i].i = NA_REAL;
-        }
-        break;
-    case STRSXP:
-        if (0 <= ii && ii < nx && ii != NA_INTEGER)
-        SET_STRING_ELT(result, i, STRING_ELT(x, ii));
-        else
-        SET_STRING_ELT(result, i, NA_STRING);
-        break;
-    case VECSXP:
-    case EXPRSXP:
-        if (0 <= ii && ii < nx && ii != NA_INTEGER)
-        SET_VECTOR_ELT(result, i, VECTOR_ELT(x, ii));
-        else
-        SET_VECTOR_ELT(result, i, R_NilValue);
-        break;
-    case LISTSXP:
-        /* cannot happen: pairlists are coerced to lists */
-    case LANGSXP:
-        if (0 <= ii && ii < nx && ii != NA_INTEGER) {
-        tmp2 = nthcdr(x, ii);
-        SETCAR(tmp, CAR(tmp2));
-        SET_TAG(tmp, TAG(tmp2));
-        }
-        else
-        SETCAR(tmp, R_NilValue);
-        tmp = CDR(tmp);
-        break;
-    case RAWSXP:
-        if (0 <= ii && ii < nx && ii != NA_INTEGER)
-        RAW(result)[i] = RAW(x)[ii];
-        else
-        RAW(result)[i] = (Rbyte) 0;
-        break;
-    default:
-        error("error in subset\n");
-//      errorcall(call, R_MSG_ob_nonsub, type2char(mode));
-        break;
-    }
-    }
-    return result;
-} //}}}
-
-SEXP do_subset_xts(SEXP x, SEXP sr, SEXP sc, SEXP drop) //SEXP s, SEXP call, int drop)
-{
-    SEXP attr, result, dim;
-    int nr, nc, nrs, ncs;
-    int i, j, ii, jj, ij, iijj;
-    int mode;
-    int *int_x=NULL, *int_result=NULL, *int_newindex=NULL, *int_index=NULL;
-    double *real_x=NULL, *real_result=NULL, *real_newindex=NULL, *real_index=NULL;
-
-    nr = nrows(x);
-    nc = ncols(x);
-
-    if( length(x)==0 )
-      return x;
-
-    dim = getAttrib(x, R_DimSymbol);
-
-    nrs = LENGTH(sr);
-    ncs = LENGTH(sc);
-    int *int_sr=NULL, *int_sc=NULL;
-    int_sr = INTEGER(sr);
-    int_sc = INTEGER(sc);
-
-    mode = TYPEOF(x);
-
-    result = allocVector(mode, nrs*ncs);
-    PROTECT(result);
-
-
-    if( mode==INTSXP ) {
-      int_x = INTEGER(x);
-      int_result = INTEGER(result);
-    } else
-    if( mode==REALSXP ) {
-      real_x = REAL(x);
-      real_result = REAL(result);
-    }
-
-    /* code to handle index of xts object efficiently */
-    SEXP index, newindex;
-    int indx;
-
-    index = getAttrib(x, install("index"));
-    PROTECT(index);
-
-    if(TYPEOF(index) == INTSXP) {
-      newindex = allocVector(INTSXP, LENGTH(sr));
-      PROTECT(newindex);
-      int_newindex = INTEGER(newindex);
-      int_index = INTEGER(index);
-      for(indx = 0; indx < nrs; indx++) {
-        int_newindex[indx] = int_index[ (int_sr[indx])-1];
-      }
-      copyAttributes(index, newindex);
-      setAttrib(result, install("index"), newindex);
-      UNPROTECT(1);
-    }
-    if(TYPEOF(index) == REALSXP) {
-      newindex = allocVector(REALSXP, LENGTH(sr));
-      PROTECT(newindex);
-      real_newindex = REAL(newindex);
-      real_index = REAL(index);
-      for(indx = 0; indx < nrs; indx++) {
-        real_newindex[indx] = real_index[ (int_sr[indx])-1 ];
-      }
-      copyAttributes(index, newindex);
-      setAttrib(result, install("index"), newindex);
-      UNPROTECT(1);
-    }
-
-    for (i = 0; i < nrs; i++) {
-      ii = int_sr[i];
-      if (ii != NA_INTEGER) {
-        if (ii < 1 || ii > nr)
-          error("i is out of range\n");
-        ii--;
-      }
-      /* Begin column loop */
-      for (j = 0; j < ncs; j++) {
-        //jj = INTEGER(sc)[j];
-        jj = int_sc[j];
-        if (jj != NA_INTEGER) {
-        if (jj < 1 || jj > nc)
-          error("j is out of range\n");
-        jj--;
-        }
-        ij = i + j * nrs;
-        if (ii == NA_INTEGER || jj == NA_INTEGER) {
-          switch ( mode ) {
-            case REALSXP:
-                 real_result[ij] = NA_REAL;
-                 break;
-            case LGLSXP:
-            case INTSXP:
-                 int_result[ij] = NA_INTEGER;
-                 break;
-            case CPLXSXP:
-                 COMPLEX(result)[ij].r = NA_REAL;
-                 COMPLEX(result)[ij].i = NA_REAL;
-                 break;
-            case STRSXP:
-                 SET_STRING_ELT(result, ij, NA_STRING);
-                 break;
-            case VECSXP:
-                 SET_VECTOR_ELT(result, ij, R_NilValue);
-                 break;
-            case RAWSXP:
-                 RAW(result)[ij] = (Rbyte) 0;
-                 break;
-            default:
-                 error("xts subscripting not handled for this type");
-                 break;
-          }
-        }
-        else {
-          iijj = ii + jj * nr;
-          switch ( mode ) {
-            case REALSXP:
-                 real_result[ij] = real_x[iijj];
-                 break;
-            case LGLSXP:
-                 LOGICAL(result)[ij] = LOGICAL(x)[iijj];
-                 break;
-            case INTSXP:
-                 int_result[ij] = int_x[iijj]; 
-                 break;
-            case CPLXSXP:
-                 COMPLEX(result)[ij] = COMPLEX(x)[iijj];
-                 break;
-            case STRSXP:
-                 SET_STRING_ELT(result, ij, STRING_ELT(x, iijj));
-                 break;
-            case VECSXP:
-                 SET_VECTOR_ELT(result, ij, VECTOR_ELT(x, iijj));
-                 break;
-            case RAWSXP:
-                 RAW(result)[ij] = RAW(x)[iijj];
-                 break;
-            default:
-                 error("matrix subscripting not handled for this type");
-                 break;
-          }
-        }
-      } /* end of column loop */
-    } /* end of row loop */
-    if(nrs >= 0 && ncs >= 0 && !isNull(dim)) {
-      PROTECT(attr = allocVector(INTSXP, 2));
-      INTEGER(attr)[0] = nrs;
-      INTEGER(attr)[1] = ncs;
-      setAttrib(result, R_DimSymbol, attr);
-      UNPROTECT(1);
-    }
-
-    /* The matrix elements have been transferred.  Now we need to */
-    /* transfer the attributes.  Most importantly, we need to subset */
-    /* the dimnames of the returned value. */
-
-    if (nrs >= 0 && ncs >= 0 && !isNull(dim)) {
-    SEXP dimnames, dimnamesnames, newdimnames;
-    dimnames = getAttrib(x, R_DimNamesSymbol);
-    dimnamesnames = getAttrib(dimnames, R_NamesSymbol);
-    if (!isNull(dimnames)) {
-        PROTECT(newdimnames = allocVector(VECSXP, 2));
-        if (TYPEOF(dimnames) == VECSXP) {
-          SET_VECTOR_ELT(newdimnames, 0,
-            xtsExtractSubset(VECTOR_ELT(dimnames, 0),
-                  allocVector(STRSXP, nrs), sr));
-          SET_VECTOR_ELT(newdimnames, 1,
-            xtsExtractSubset(VECTOR_ELT(dimnames, 1),
-                  allocVector(STRSXP, ncs), sc));
-        }
-        else {
-          SET_VECTOR_ELT(newdimnames, 0,
-            xtsExtractSubset(CAR(dimnames),
-                  allocVector(STRSXP, nrs), sr));
-          SET_VECTOR_ELT(newdimnames, 1,
-            xtsExtractSubset(CADR(dimnames),
-                  allocVector(STRSXP, ncs), sc));
-        }
-        setAttrib(newdimnames, R_NamesSymbol, dimnamesnames);
-        setAttrib(result, R_DimNamesSymbol, newdimnames);
-        UNPROTECT(1);
-    }
-    }
-
-    copyAttributes(x, result);
-    if(ncs == 1 && LOGICAL(drop)[0])
-      setAttrib(result, R_DimSymbol, R_NilValue);
-
-    UNPROTECT(2);
-    return result;
-}