Logo Search packages:      
Sourcecode: rcpp version File versions

Rcpp.cpp

// -*- mode: C++; c-indent-level: 4; c-basic-offset: 4; tab-width: 8 -*-
//
// Rcpp.cpp: R/C++ interface class library
//
// Copyright (C) 2005 - 2006 Dominick Samperi
// Copyright (C) 2008 - 2009 Dirk Eddelbuettel
//
// This library is free software; you can redistribute it and/or modify it 
// under the terms of the GNU Lesser General Public License as published by 
// the Free Software Foundation; either version 2.1 of the License, or (at 
// your option) any later version.
//
// This library 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 Lesser General Public 
// License for more details.
//
// You should have received a copy of the GNU Lesser General Public License 
// along with this library; if not, write to the Free Software Foundation, 
// Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 

#include "Rcpp.h"

RcppParams::RcppParams(SEXP params) {
    if (!Rf_isNewList(params))
      throw std::range_error("RcppParams: non-list passed to constructor");
    int len = Rf_length(params);
    SEXP names = Rf_getAttrib(params, R_NamesSymbol);
    if (names == R_NilValue)
      throw std::range_error("RcppParams: list must have named elements");
    for (int i = 0; i < len; i++) {
      std::string nm = std::string(CHAR(STRING_ELT(names,i)));
      if (nm.size() == 0)
          throw std::range_error("RcppParams: all list elements must be named");
      pmap[nm] = i;
    }
    _params = params;
}

void RcppParams::checkNames(char *inputNames[], int len) {
    for (int i = 0; i < len; i++) {
      std::map<std::string,int>::iterator iter = pmap.find(inputNames[i]);
      if (iter == pmap.end()) {
          std::string mesg = "RcppParams::checkNames: missing required parameter ";
          throw std::range_error(mesg+inputNames[i]);
      }
    }
}

RcppFrame::RcppFrame(SEXP df) {
    if (!Rf_isNewList(df))
      throw std::range_error("RcppFrame::RcppFrame: invalid data frame.");
    int ncol = Rf_length(df);
    SEXP names = Rf_getAttrib(df, R_NamesSymbol);
    colNames.resize(ncol);
    SEXP colData = VECTOR_ELT(df,0); // First column of data.
    int nrow = Rf_length(colData);
    if (nrow == 0)
      throw std::range_error("RcppFrame::RcppFrame: zero lenth column.");

    // Allocate storage for table.
    table.resize(nrow);
    for (int r = 0; r < nrow; r++)
      table[r].resize(ncol);
    
    for (int i=0; i < ncol; i++) {
      colNames[i] = std::string(CHAR(STRING_ELT(names,i)));
      SEXP colData = VECTOR_ELT(df,i);
      if (!Rf_isVector(colData) || Rf_length(colData) != nrow)
          throw std::range_error("RcppFrame::RcppFrame: invalid column.");

      // Check for Date class. Currently R stores the date ordinal in a
      // real value. We check for Date under both Real and Integer values
      // as insurance against future changes.
      bool isDateClass = false;
      SEXP classname = Rf_getAttrib(colData, R_ClassSymbol);
      if (classname != R_NilValue)
          isDateClass = (strcmp(CHAR(STRING_ELT(classname,0)),"Date") == 0);

      if (Rf_isReal(colData)) {
          if (isDateClass) {
            for (int j=0; j < nrow; j++) // Column of Date's
                table[j][i].setDateValue(RcppDate((int)REAL(colData)[j]));
          }
          else // Column of REAL's
            for (int j=0; j < nrow; j++)
                table[j][i].setDoubleValue(REAL(colData)[j]);
      }
      else if (Rf_isInteger(colData)) {
          if (isDateClass) {
            for (int j=0; j < nrow; j++) // Column of Date's
                table[j][i].setDateValue(RcppDate(INTEGER(colData)[j]));
          }
          else
            for (int j=0; j < nrow; j++)
                table[j][i].setIntValue(INTEGER(colData)[j]);
      }
      else if (Rf_isString(colData)) { // Non-factor string column
          for (int j=0; j < nrow; j++)
            table[j][i].setStringValue(std::string(CHAR(STRING_ELT(colData,j))));
      }
      else if (Rf_isFactor(colData)) { // Factor column.
          SEXP names = Rf_getAttrib(colData, R_LevelsSymbol);
          int numLevels = Rf_length(names);
          std::string *levelNames = new std::string[numLevels];
          for (int k=0; k < numLevels; k++)
            levelNames[k] = std::string(CHAR(STRING_ELT(names,k)));
          for (int j=0; j < nrow; j++)
            table[j][i].setFactorValue(levelNames, numLevels,
                                 INTEGER(colData)[j]);
          delete [] levelNames;
      }
      else if (Rf_isLogical(colData)) {
          for (int j=0; j < nrow; j++) {
            table[j][i].setLogicalValue(INTEGER(colData)[j]);
          }
      }
      else
          throw std::range_error("RcppFrame::RcppFrame: unsupported data frame column type.");
    }
}

double RcppParams::getDoubleValue(std::string name) {
    std::map<std::string,int>::iterator iter = pmap.find(name);
    if (iter == pmap.end()) {
      std::string mesg = "RcppParams::getDoubleValue: no such name: ";
      throw std::range_error(mesg+name);
    }
    int posn = iter->second;
    SEXP elt = VECTOR_ELT(_params,posn);
    if (!Rf_isNumeric(elt) || Rf_length(elt) != 1) {
      std::string mesg = "RcppParams::getDoubleValue: must be scalar ";
      throw std::range_error(mesg+name);
    }
    if (Rf_isInteger(elt))
      return (double)INTEGER(elt)[0];
    else if (Rf_isReal(elt))
      return REAL(elt)[0];
    else {
      std::string mesg = "RcppParams::getDoubleValue: invalid value for ";
      throw std::range_error(mesg+name);
    }
    return 0; // never get here
}

int RcppParams::getIntValue(std::string name) {
    std::map<std::string,int>::iterator iter = pmap.find(name);
    if (iter == pmap.end()) {
      std::string mesg = "RcppParams::getIntValue: no such name: ";
      throw std::range_error(mesg+name);
    }
    int posn = iter->second;
    SEXP elt = VECTOR_ELT(_params,posn);
    if (!Rf_isNumeric(elt) || Rf_length(elt) != 1) {
      std::string mesg = "RcppParams::getIntValue: must be scalar: ";
      throw std::range_error(mesg+name);
    }
    if (Rf_isInteger(elt))
      return INTEGER(elt)[0];
    else if (Rf_isReal(elt))
      return (int)REAL(elt)[0];
    else {
      std::string mesg = "RcppParams::getIntValue: invalid value for: ";
      throw std::range_error(mesg+name);
    }
    return 0; // never get here
}

bool RcppParams::getBoolValue(std::string name) {
    std::map<std::string,int>::iterator iter = pmap.find(name);
    if (iter == pmap.end()) {
      std::string mesg = "RcppParams::getBoolValue: no such name: ";
      throw std::range_error(mesg+name);
    }
    int posn = iter->second;
    SEXP elt = VECTOR_ELT(_params,posn);
    if (Rf_isLogical(elt))
      return INTEGER(elt)[0];
    else {
      std::string mesg = "RcppParams::getBoolValue: invalid value for: ";
      throw std::range_error(mesg+name);
    }
    return false; // never get here
}

std::string RcppParams::getStringValue(std::string name) {
    std::map<std::string,int>::iterator iter = pmap.find(name);
    if (iter == pmap.end()) {
      std::string mesg = "RcppParams::getStringValue: no such name: ";
      throw std::range_error(mesg+name);
    }
    int posn = iter->second;
    SEXP elt = VECTOR_ELT(_params,posn);
    if (Rf_isString(elt))
            return std::string(CHAR(STRING_ELT(elt,0)));
    else {
      std::string mesg = "RcppParams::getStringValue: invalid value for: ";
      throw std::range_error(mesg+name);
    }
    return ""; // never get here
}

RcppDate RcppParams::getDateValue(std::string name) {
    std::map<std::string,int>::iterator iter = pmap.find(name);
    if (iter == pmap.end()) {
      std::string mesg = "RcppParams::getDateValue: no such name: ";
      throw std::range_error(mesg+name);
    }
    int posn = iter->second;
    SEXP elt = VECTOR_ELT(_params,posn);
    if (!Rf_isNumeric(elt) || Rf_length(elt) != 1) {
      std::string mesg = "RcppParams::getDateValue: invalide date: ";
      throw std::range_error(mesg+name);
    }

    int d;
    if (Rf_isReal(elt)) // R stores julian value in a double.
      d = (int)REAL(elt)[0];
    else {
      std::string mesg = "RcppParams::getDateValue: invalid value for: ";
      throw std::range_error(mesg+name);
    }
    return RcppDate(d);
}

RcppDatetime RcppParams::getDatetimeValue(std::string name) {
    std::map<std::string,int>::iterator iter = pmap.find(name);
    if (iter == pmap.end()) {
        std::string mesg = "RcppParams::getDatetimeValue: no such name: ";
      throw std::range_error(mesg+name);
    }
    int posn = iter->second;
    SEXP elt = VECTOR_ELT(_params, posn);
    if (!Rf_isNumeric(elt) || Rf_length(elt) != 1) {
      std::string mesg = "RcppParams::getDateValue: invalide date: ";
      throw std::range_error(mesg+name);
    }
    double d;
    if (Rf_isReal(elt))       // R stores POSIXt as a double
      d = REAL(elt)[0];
    else {
      std::string mesg = "RcppParams::getDatetimeValue: invalid value for: ";
      throw std::range_error(mesg+name);
    }
    return RcppDatetime(d);
}

RcppDateVector::RcppDateVector(SEXP vec) {
    int i;
    if (!Rf_isNumeric(vec) || Rf_isMatrix(vec) || Rf_isLogical(vec))
      throw std::range_error("RcppDateVector: invalid numeric vector in constructor");
    int len = Rf_length(vec);
    if (len == 0)
      throw std::range_error("RcppDateVector: null vector in constructor");
    v = new RcppDate[len];
    for (i = 0; i < len; i++)
      v[i] = RcppDate((int)REAL(vec)[i]);
    length = len;
}

RcppDatetimeVector::RcppDatetimeVector(SEXP vec) {
    int i;
    if (!Rf_isNumeric(vec) || Rf_isMatrix(vec) || Rf_isLogical(vec))
      throw std::range_error("RcppDatetimeVector: invalid numeric vector in constructor");
    int len = Rf_length(vec);
    if (len == 0)
      throw std::range_error("RcppDatetimeVector: null vector in constructor");
    v = new RcppDatetime[len];
    for (i = 0; i < len; i++)
      v[i] = RcppDatetime(REAL(vec)[i]);
    length = len;
}

RcppStringVector::RcppStringVector(SEXP vec) {
    int i;
    if (Rf_isMatrix(vec) || Rf_isLogical(vec))
      throw std::range_error("RcppStringVector: invalid numeric vector in constructor");
    if (!Rf_isString(vec))
      throw std::range_error("RcppStringVector: invalid string");
    int len = Rf_length(vec);
    if (len == 0)
      throw std::range_error("RcppStringVector: null vector in constructor");
    v = new std::string[len];
    for (i = 0; i < len; i++)
      v[i] = std::string(CHAR(STRING_ELT(vec,i)));
    length = len;
}

template <typename T>
RcppVector<T>::RcppVector(SEXP vec) {
    int i;

    // The function Rf_isVector returns TRUE for vectors AND
    // matrices, so it does not distinguish. We could
    // check the dim attribute here to be sure that it
    // is not present (i.e., dimAttr == R_NilValue, not 0!).
    // But it is easier to simply check if it is set via
    // Rf_isMatrix (in which case we don't have a vector).
    if (!Rf_isNumeric(vec) || Rf_isMatrix(vec) || Rf_isLogical(vec))
      throw std::range_error("RcppVector: invalid numeric vector in constructor");
    len = Rf_length(vec);
    v = (T *)R_alloc(len, sizeof(T));
    if (Rf_isInteger(vec)) {
      for (i = 0; i < len; i++)
          v[i] = (T)(INTEGER(vec)[i]);
    } 
    else if (Rf_isReal(vec)) {
      for (i = 0; i < len; i++)
          v[i] = (T)(REAL(vec)[i]);
    }
}

template <typename T>
RcppVector<T>::RcppVector(int _len) {
    len = _len;
    v = (T *)R_alloc(len, sizeof(T));
    for (int i = 0; i < len; i++)
      v[i] = 0;
}

template <typename T>
T *RcppVector<T>::cVector() {
    T* tmp = (T *)R_alloc(len, sizeof(T));
    for (int i = 0; i < len; i++)
      tmp[i] = v[i];
    return tmp;
}

template <typename T>
std::vector<T> RcppVector<T>::stlVector() {
    std::vector<T> tmp(len);
    for (int i = 0; i < len; i++)
      tmp[i] = v[i];
    return tmp;
}

template <typename T>
RcppMatrix<T>::RcppMatrix(SEXP mat) {

    if (!Rf_isNumeric(mat) || !Rf_isMatrix(mat))
      throw std::range_error("RcppMatrix: invalid numeric matrix in constructor");

    // Get matrix dimensions
    SEXP dimAttr = Rf_getAttrib(mat, R_DimSymbol);
    dim1 = INTEGER(dimAttr)[0];
    dim2 = INTEGER(dimAttr)[1];

    // We guard against  the possibility that R might pass an integer matrix.
    // Can be prevented using R code: temp <- as.double(a), dim(temp) <- dim(a)
    int i,j;
    int isInt = Rf_isInteger(mat);
    T *m = (T *)R_alloc(dim1*dim2, sizeof(T));
    a = (T **)R_alloc(dim1, sizeof(T *));
    for (i = 0; i < dim1; i++)
      a[i] = m + i*dim2;
    if (isInt) {
      for (i=0; i < dim1; i++)
          for (j=0; j < dim2; j++)
            a[i][j] = (T)(INTEGER(mat)[i+dim1*j]);
    } 
    else {
      for (i=0; i < dim1; i++)
          for (j=0; j < dim2; j++)
            a[i][j] = (T)(REAL(mat)[i+dim1*j]);
    } 
}

template <typename T>
RcppMatrix<T>::RcppMatrix(int _dim1, int _dim2) {
    dim1 = _dim1;
    dim2 = _dim2;
    int i,j;
    T *m = (T *)R_alloc(dim1*dim2, sizeof(T));
    a = (T **)R_alloc(dim1, sizeof(T *));
    for (i = 0; i < dim1; i++)
      a[i] = m + i*dim2;
    for (i=0; i < dim1; i++)
      for (j=0; j < dim2; j++)
          a[i][j] = 0;
}

template <typename T>
std::vector<std::vector<T> > RcppMatrix<T>::stlMatrix() {
    int i,j;
    std::vector<std::vector<T> > temp;
    for (i = 0; i < dim1; i++) {
      temp.push_back(std::vector<T>(dim2));
    }
    for (i = 0; i < dim1; i++)
      for (j = 0; j < dim2; j++)
          temp[i][j] = a[i][j];
    return temp;
}

template <typename T>
T **RcppMatrix<T>::cMatrix() {
    int i,j;
    T *m = (T *)R_alloc(dim1*dim2, sizeof(T));
    T **tmp = (T **)R_alloc(dim1, sizeof(T *));
    for (i = 0; i < dim1; i++)
      tmp[i] = m + i*dim2;
    for (i=0; i < dim1; i++)
      for (j=0; j < dim2; j++)
          tmp[i][j] = a[i][j];
    return tmp;
}

// Explicit instantiation (required for external linkage)
template class RcppVector<int>;
template class RcppVector<double>;
template class RcppMatrix<int>;
template class RcppMatrix<double>;

template <typename T>
RcppVectorView<T>::RcppVectorView(SEXP vec) {
    if (!Rf_isNumeric(vec) || Rf_isMatrix(vec) || Rf_isLogical(vec))
      throw std::range_error("RcppVectorView: invalid numeric vector in constructor");
    len = Rf_length(vec);
    if (Rf_isInteger(vec)) v = (T *)(INTEGER(vec));
    else if (Rf_isReal(vec)) v = (T *)(REAL(vec));
}

template class RcppVectorView<int>;
template class RcppVectorView<double>;

template <typename T>
RcppMatrixView<T>::RcppMatrixView(SEXP mat) {
    if (!Rf_isNumeric(mat) || !Rf_isMatrix(mat))
      throw std::range_error("RcppMatrixView: invalid numeric matrix in constructor");
    // Get matrix dimensions
    SEXP dimAttr = Rf_getAttrib(mat, R_DimSymbol);
    d1 = INTEGER(dimAttr)[0];
    d2 = INTEGER(dimAttr)[1];
    if (Rf_isInteger(mat)) a = (T *)(INTEGER(mat));
    else if (Rf_isReal(mat)) a = (T *)(REAL(mat));
}

template class RcppMatrixView<int>;
template class RcppMatrixView<double>;

RcppStringVectorView::RcppStringVectorView(SEXP vec) {
    //int i;
    if (Rf_isMatrix(vec) || Rf_isLogical(vec))
      throw std::range_error("RcppStringVectorView: invalid numeric vector in constructor");
    if (!Rf_isString(vec))
      throw std::range_error("RcppStringVectorView: invalid string");
    int len = Rf_length(vec);
    if (len == 0)
      throw std::range_error("RcppStringVectorView: null vector in constructor");
    //v = new (char *)[len];
    //for (i = 0; i < len; i++)
    //      v[i] = string(CHAR(STRING_ELT(vec,i)));
    length = len;
    v = vec;
}


void RcppResultSet::add(std::string name, RcppDate& date) {
    SEXP value = PROTECT(Rf_allocVector(REALSXP, 1));
    numProtected++;
    REAL(value)[0] = date.getJDN() - RcppDate::Jan1970Offset;
    SEXP dateclass = PROTECT(Rf_allocVector(STRSXP,1));
    numProtected++;
    SET_STRING_ELT(dateclass, 0, Rf_mkChar("Date"));
    Rf_setAttrib(value, R_ClassSymbol, dateclass); 
    values.push_back(make_pair(name, value));
}

void RcppResultSet::add(std::string name, RcppDatetime& datetime) {
    SEXP value = PROTECT(Rf_allocVector(REALSXP, 1));
    numProtected++;
    REAL(value)[0] = datetime.getFractionalTimestamp();
    SEXP datetimeclass = PROTECT(Rf_allocVector(STRSXP,2));
    numProtected++;
    SET_STRING_ELT(datetimeclass, 0, Rf_mkChar("POSIXt"));
    SET_STRING_ELT(datetimeclass, 1, Rf_mkChar("POSIXct"));
    Rf_setAttrib(value, R_ClassSymbol, datetimeclass); 
    values.push_back(make_pair(name, value));
}

void RcppResultSet::add(std::string name, double x) {
    SEXP value = PROTECT(Rf_allocVector(REALSXP, 1));
    numProtected++;
    REAL(value)[0] = x;
    values.push_back(make_pair(name, value));
}

void RcppResultSet::add(std::string name, int i) {
    SEXP value = PROTECT(Rf_allocVector(INTSXP, 1));
    numProtected++;
    INTEGER(value)[0] = i;
    values.push_back(make_pair(name, value));
}

void RcppResultSet::add(std::string name, std::string strvalue) {
    SEXP value = PROTECT(Rf_allocVector(STRSXP, 1));
    numProtected++;
    SET_STRING_ELT(value, 0, Rf_mkChar(strvalue.c_str()));
    values.push_back(make_pair(name, value));
}

void RcppResultSet::add(std::string name, double *vec, int len) {
    if (vec == 0)
      throw std::range_error("RcppResultSet::add: NULL double vector");
    SEXP value = PROTECT(Rf_allocVector(REALSXP, len));
    numProtected++;
    for (int i = 0; i < len; i++)
      REAL(value)[i] = vec[i];
    values.push_back(make_pair(name, value));
}

void RcppResultSet::add(std::string name, RcppDateVector& datevec) {
    SEXP value = PROTECT(Rf_allocVector(REALSXP, datevec.size()));
    numProtected++;
    for (int i = 0; i < datevec.size(); i++) {
      REAL(value)[i] = datevec(i).getJDN() - RcppDate::Jan1970Offset;
    }
    SEXP dateclass = PROTECT(Rf_allocVector(STRSXP,1));
    numProtected++;
    SET_STRING_ELT(dateclass, 0, Rf_mkChar("Date"));
    Rf_setAttrib(value, R_ClassSymbol, dateclass); 
    values.push_back(make_pair(name, value));
}

void RcppResultSet::add(std::string name, RcppDatetimeVector &dtvec) {
    SEXP value = PROTECT(Rf_allocVector(REALSXP, dtvec.size()));
    numProtected++;
    for (int i = 0; i < dtvec.size(); i++) {
      REAL(value)[i] = dtvec(i).getFractionalTimestamp();
    }
    SEXP datetimeclass = PROTECT(Rf_allocVector(STRSXP,2));
    numProtected++;
    SET_STRING_ELT(datetimeclass, 0, Rf_mkChar("POSIXt"));
    SET_STRING_ELT(datetimeclass, 1, Rf_mkChar("POSIXct"));
    Rf_setAttrib(value, R_ClassSymbol, datetimeclass); 
    values.push_back(make_pair(name, value));
}

void RcppResultSet::add(std::string name, RcppStringVector& stringvec) {
    int len = (int)stringvec.size();
    SEXP value = PROTECT(Rf_allocVector(STRSXP, len));
    numProtected++;
    for (int i = 0; i < len; i++)
        SET_STRING_ELT(value, i, Rf_mkChar(stringvec(i).c_str()));
    values.push_back(make_pair(name, value));
}

void RcppResultSet::add(std::string name, int *vec, int len) {
    if (vec == 0)
      throw std::range_error("RcppResultSet::add: NULL int vector");
    SEXP value = PROTECT(Rf_allocVector(INTSXP, len));
    numProtected++;
    for (int i = 0; i < len; i++)
      INTEGER(value)[i] = vec[i];
    values.push_back(make_pair(name, value));
}

void RcppResultSet::add(std::string name, double **mat, int nx, int ny) {
    if (mat == 0)
      throw std::range_error("RcppResultSet::add: NULL double matrix");
    SEXP value = PROTECT(Rf_allocMatrix(REALSXP, nx, ny));
    numProtected++;
    for (int i = 0; i < nx; i++)
      for (int j = 0; j < ny; j++)
          REAL(value)[i + nx*j] = mat[i][j];
    values.push_back(make_pair(name, value));
}

void RcppResultSet::add(std::string name, int **mat, int nx, int ny) {
    if (mat == 0)
      throw std::range_error("RcppResultSet::add: NULL int matrix");
    SEXP value = PROTECT(Rf_allocMatrix(INTSXP, nx, ny));
    numProtected++;
    for (int i = 0; i < nx; i++)
      for (int j = 0; j < ny; j++)
          INTEGER(value)[i + nx*j] = mat[i][j];
    values.push_back(make_pair(name, value));
}

void RcppResultSet::add(std::string name, std::vector<std::string>& vec) {
    if (vec.size() == 0)
      throw std::range_error("RcppResultSet::add; zero length vector<string>");
    int len = (int)vec.size();
    SEXP value = PROTECT(Rf_allocVector(STRSXP, len));
    numProtected++;
    for (int i = 0; i < len; i++)
        SET_STRING_ELT(value, i, Rf_mkChar(vec[i].c_str()));
    values.push_back(make_pair(name, value));
}

void RcppResultSet::add(std::string name, std::vector<int>& vec) {
    if (vec.size() == 0)
      throw std::range_error("RcppResultSet::add; zero length vector<int>");
    int len = (int)vec.size();
    SEXP value = PROTECT(Rf_allocVector(INTSXP, len));
    numProtected++;
    for (int i = 0; i < len; i++)
      INTEGER(value)[i] = vec[i];
    values.push_back(make_pair(name, value));
}

void RcppResultSet::add(std::string name, std::vector<double>& vec) {
    if (vec.size() == 0)
      throw std::range_error("RcppResultSet::add; zero length vector<double>");
    int len = (int)vec.size();
    SEXP value = PROTECT(Rf_allocVector(REALSXP, len));
    numProtected++;
    for (int i = 0; i < len; i++)
      REAL(value)[i] = vec[i];
    values.push_back(make_pair(name, value));
}

void RcppResultSet::add(std::string name, std::vector<std::vector<int> >& mat) {
    if (mat.size() == 0)
      throw std::range_error("RcppResultSet::add: zero length vector<vector<int> >");
    else if (mat[0].size() == 0)
      throw std::range_error("RcppResultSet::add: no columns in vector<vector<int> >");
    int nx = (int)mat.size();
    int ny = (int)mat[0].size();
    SEXP value = PROTECT(Rf_allocMatrix(INTSXP, nx, ny));
    numProtected++;
    for (int i = 0; i < nx; i++)
      for (int j = 0; j < ny; j++)
          INTEGER(value)[i + nx*j] = mat[i][j];
    values.push_back(make_pair(name, value));
}

void RcppResultSet::add(std::string name, std::vector<std::vector<double> >& mat) {
    if (mat.size() == 0)
      throw std::range_error("RcppResultSet::add: zero length vector<vector<double> >");
    else if (mat[0].size() == 0)
      throw std::range_error("RcppResultSet::add: no columns in vector<vector<double> >");
    int nx = (int)mat.size();
    int ny = (int)mat[0].size();
    SEXP value = PROTECT(Rf_allocMatrix(REALSXP, nx, ny));
    numProtected++;
    for (int i = 0; i < nx; i++)
      for (int j = 0; j < ny; j++)
          REAL(value)[i + nx*j] = mat[i][j];
    values.push_back(make_pair(name, value));
}

void RcppResultSet::add(std::string name, RcppVector<int>& vec) {
    int len = vec.size();
    int *a = vec.cVector();
    SEXP value = PROTECT(Rf_allocVector(INTSXP, len));
    numProtected++;
    for (int i = 0; i < len; i++)
      INTEGER(value)[i] = a[i];
    values.push_back(make_pair(name, value));
}

void RcppResultSet::add(std::string name, RcppVector<double>& vec) {
    int len = vec.size();
    double *a = vec.cVector();
    SEXP value = PROTECT(Rf_allocVector(REALSXP, len));
    numProtected++;
    for (int i = 0; i < len; i++)
      REAL(value)[i] = a[i];
    values.push_back(make_pair(name, value));
}

void RcppResultSet::add(std::string name, RcppMatrix<int>& mat) {
    int nx = mat.getDim1();
    int ny = mat.getDim2();
    int **a = mat.cMatrix();
    SEXP value = PROTECT(Rf_allocMatrix(INTSXP, nx, ny));
    numProtected++;
    for (int i = 0; i < nx; i++)
      for (int j = 0; j < ny; j++)
          INTEGER(value)[i + nx*j] = a[i][j];
    values.push_back(make_pair(name, value));
}

void RcppResultSet::add(std::string name, RcppMatrix<double>& mat) {
    int nx = mat.getDim1();
    int ny = mat.getDim2();
    double **a = mat.cMatrix();
    SEXP value = PROTECT(Rf_allocMatrix(REALSXP, nx, ny));
    numProtected++;
    for (int i = 0; i < nx; i++)
      for (int j = 0; j < ny; j++)
          REAL(value)[i + nx*j] = a[i][j];
    values.push_back(make_pair(name, value));
}

void RcppResultSet::add(std::string name, RcppFrame& frame) {
    std::vector<std::string> colNames = frame.getColNames();
    std::vector<std::vector<ColDatum> > table = frame.getTableData();
    int ncol = colNames.size();
    int nrow = table.size();
    SEXP rl = PROTECT(Rf_allocVector(VECSXP,ncol));
    SEXP nm = PROTECT(Rf_allocVector(STRSXP,ncol));
    numProtected += 2;
    for (int i=0; i < ncol; i++) {
      SEXP value, names;
      if (table[0][i].getType() == COLTYPE_DOUBLE) {
          value = PROTECT(Rf_allocVector(REALSXP,nrow));
          numProtected++;
          for (int j=0; j < nrow; j++)
            REAL(value)[j] = table[j][i].getDoubleValue();
      } else if (table[0][i].getType() == COLTYPE_INT) {
          value = PROTECT(Rf_allocVector(INTSXP,nrow));
          numProtected++;
          for (int j=0; j < nrow; j++)
            INTEGER(value)[j] = table[j][i].getIntValue();
      } else if (table[0][i].getType() == COLTYPE_FACTOR) {
          value = PROTECT(Rf_allocVector(INTSXP,nrow));
          numProtected++;
          int levels = table[0][i].getFactorNumLevels();
          names = PROTECT(Rf_allocVector(STRSXP,levels));
          numProtected++;
          std::string *levelNames = table[0][i].getFactorLevelNames();
          for (int k=0; k < levels; k++)
            SET_STRING_ELT(names, k, Rf_mkChar(levelNames[k].c_str()));
          for (int j=0; j < nrow; j++) {
            int level = table[j][i].getFactorLevel();
            INTEGER(value)[j] = level;
          }
          Rf_setAttrib(value, R_LevelsSymbol, names);
          SEXP factorclass = PROTECT(Rf_allocVector(STRSXP,1));
          numProtected++;
          SET_STRING_ELT(factorclass, 0, Rf_mkChar("factor"));
          Rf_setAttrib(value, R_ClassSymbol, factorclass); 
      } else if (table[0][i].getType() == COLTYPE_STRING) {
          value = PROTECT(Rf_allocVector(STRSXP,nrow));
          numProtected++;
          for (int j=0; j < nrow; j++) {
            SET_STRING_ELT(value, j, Rf_mkChar(table[j][i].getStringValue().c_str()));
          }
      } else if (table[0][i].getType() == COLTYPE_LOGICAL) {
          value = PROTECT(Rf_allocVector(LGLSXP,nrow));
          numProtected++;
          for (int j=0; j < nrow; j++) {
            LOGICAL(value)[j] = table[j][i].getLogicalValue();
          }
      } else if (table[0][i].getType() == COLTYPE_DATE) {
          value = PROTECT(Rf_allocVector(REALSXP,nrow));
          numProtected++;
          for (int j=0; j < nrow; j++)
            REAL(value)[j] = table[j][i].getDateRCode();
          SEXP dateclass = PROTECT(Rf_allocVector(STRSXP,1));
          numProtected++;
          SET_STRING_ELT(dateclass, 0, Rf_mkChar("Date"));
          Rf_setAttrib(value, R_ClassSymbol, dateclass); 
      } else if (table[0][i].getType() == COLTYPE_DATETIME) {
          value = PROTECT(Rf_allocVector(REALSXP,nrow));
          numProtected++;
          for (int j=0; j < nrow; j++) {
            // we could access the seconds as the internal double via getDouble but it's
            // more proper to use the proper accessor (and if we ever added code ...)
            REAL(value)[j] = table[j][i].getDatetimeValue().getFractionalTimestamp();
          }
          SEXP dateclass = PROTECT(Rf_allocVector(STRSXP,2));
          numProtected++;
          SET_STRING_ELT(dateclass, 0, Rf_mkChar("POSIXt"));
          SET_STRING_ELT(dateclass, 1, Rf_mkChar("POSIXct"));
          Rf_setAttrib(value, R_ClassSymbol, dateclass); 
      } else {
          throw std::range_error("RcppResultSet::add invalid column type");
      }
      SET_VECTOR_ELT(rl, i, value);
      SET_STRING_ELT(nm, i, Rf_mkChar(colNames[i].c_str()));
    }
    Rf_setAttrib(rl, R_NamesSymbol, nm);
    values.push_back(make_pair(name, rl));
}

void RcppResultSet::add(std::string name, SEXP sexp, bool isProtected) {
    values.push_back(make_pair(name, sexp));
    if (isProtected)
      numProtected++;
}

SEXP RcppResultSet::getReturnList() {
    int nret = (int)values.size();
    SEXP rl = PROTECT(Rf_allocVector(VECSXP,nret));
    SEXP nm = PROTECT(Rf_allocVector(STRSXP,nret));
    std::list<std::pair<std::string,SEXP> >::iterator iter = values.begin();
    for (int i = 0; iter != values.end(); iter++, i++) {
      SET_VECTOR_ELT(rl, i, iter->second);
      SET_STRING_ELT(nm, i, Rf_mkChar(iter->first.c_str()));
    }
    Rf_setAttrib(rl, R_NamesSymbol, nm);
    UNPROTECT(numProtected+2);
    return rl;
}

// Print an RcppDate.
std::ostream& operator<<(std::ostream& os, const RcppDate& date) {
    os << date.getYear() << "-" << date.getMonth() << "-" << date.getDay();
    return os;
}

// A few basic date operations.
RcppDate operator+(const RcppDate& date, int offset) {
    RcppDate temp(date.month, date.day, date.year);
    temp.jdn += offset;
    temp.jdn2mdy();
    return temp;
}

int operator-(const RcppDate& date2, const RcppDate& date1) {
    return date2.jdn - date1.jdn;
}

bool  operator<(const RcppDate &date1, const RcppDate& date2) {
    return date1.jdn < date2.jdn;
}

bool  operator>(const RcppDate &date1, const RcppDate& date2) {
    return date1.jdn > date2.jdn;
}

bool  operator>=(const RcppDate &date1, const RcppDate& date2) {
    return date1.jdn >= date2.jdn;
}

bool  operator<=(const RcppDate &date1, const RcppDate& date2) {
    return date1.jdn <= date2.jdn;
}

bool  operator==(const RcppDate &date1, const RcppDate& date2) {
    return date1.jdn == date2.jdn;
}

// Offset used to convert from R date representation to Julian day number.
const int RcppDate::Jan1970Offset = 2440588;

// Offset used to convert between R / Unix date of Jan 1, 1970 and the QL base date
const int RcppDate::QLtoJan1970Offset = 25569; 

// The Julian day number (jdn) is the number of days since Monday,
// Jan 1, 4713BC (year = -4712). Here 1BC is year 0, 2BC is year -1, etc.
// On the other hand, R measures days since Jan 1, 1970, and these dates are
// converted to jdn's by adding Jan1970Offset.
//
// mdy2jdn and jdn2mdy are inverse functions for dates back to 
// year = -4799 (4800BC).
//
// See the Wikipedia entry on Julian day number for more information 
// on these algorithms.
//

// Transform month/day/year to Julian day number.
void RcppDate::mdy2jdn() {
    int m = month, d = day, y = year;
    int a = (14 - m)/12;
    y += 4800 - a;
    m += 12*a - 3;
    jdn = (d + (153*m + 2)/5 + 365*y
         + y/4 - y/100 + y/400 - 32045);
}

// Transform from Julian day number to month/day/year.
void RcppDate::jdn2mdy() {
    int jul = jdn + 32044;
    int g = jul/146097;
    int dg = jul % 146097;
    int c = (dg/36524 + 1)*3/4;
    int dc = dg - c*36524;
    int b = dc/1461;
    int db = dc % 1461;
    int a = (db/365 + 1)*3/4;
    int da = db - a*365;
    int y = g*400 + c*100 + b*4 + a;
    int m = (da*5 + 308)/153 - 2;
    int d = da - (m + 4)*153 /5 + 122;
    y = y - 4800 + (m + 2)/12;
    m = (m + 2) % 12 + 1;
    d = d + 1;
    month = m;
    day   = d;
    year  = y;
}

SEXP RcppFunction::listCall() {
    if (names.size() != (unsigned)listSize)
      throw std::range_error("RcppFunction::listCall: no. of names != no. of items");
    if (currListPosn != listSize)
      throw std::range_error("RcppFunction::listCall: list has incorrect size");
    SEXP nm = PROTECT(Rf_allocVector(STRSXP,listSize));
    numProtected++;
    for (int i=0; i < listSize; i++)
      SET_STRING_ELT(nm, i, Rf_mkChar(names[i].c_str()));
    Rf_setAttrib(listArg, R_NamesSymbol, nm);
    SEXP R_fcall;
    PROTECT(R_fcall = Rf_lang2(fn, R_NilValue));
    numProtected++;
    SETCADR(R_fcall, listArg);
    SEXP result = Rf_eval(R_fcall, R_NilValue);
    names.clear();
    listSize = currListPosn = 0; // Ready for next call.
    return result;
}

SEXP RcppFunction::vectorCall() {
    if (vectorArg == R_NilValue)
      throw std::range_error("RcppFunction::vectorCall: vector has not been set");
    SEXP R_fcall;
    PROTECT(R_fcall = Rf_lang2(fn, R_NilValue));
    numProtected++;
    SETCADR(R_fcall, vectorArg);
    SEXP result = Rf_eval(R_fcall, R_NilValue);
    vectorArg = R_NilValue; // Ready for next call.
    return result;
}

void RcppFunction::setRVector(std::vector<double>& v) {
    vectorArg = PROTECT(Rf_allocVector(REALSXP,v.size()));
    numProtected++;
    for (int i=0; i < (int)v.size(); i++)
      REAL(vectorArg)[i] = v[i];
}

void RcppFunction::setRListSize(int n) {
    listSize = n;
    listArg = PROTECT(Rf_allocVector(VECSXP, n));
    numProtected++;
}

void RcppFunction::appendToRList(std::string name, double value) {
    if (currListPosn < 0 || currListPosn >= listSize)
      throw std::range_error("RcppFunction::appendToRList(double): list posn out of range");
    SEXP valsxp = PROTECT(Rf_allocVector(REALSXP,1));
    numProtected++;
    REAL(valsxp)[0] = value;
    SET_VECTOR_ELT(listArg, currListPosn++, valsxp);
    names.push_back(name);
}

void RcppFunction::appendToRList(std::string name, int value) {
    if (currListPosn < 0 || currListPosn >= listSize)
      throw std::range_error("RcppFunction::appendToRlist(int): posn out of range");
    SEXP valsxp = PROTECT(Rf_allocVector(INTSXP,1));
    numProtected++;
    INTEGER(valsxp)[0] = value;
    SET_VECTOR_ELT(listArg, currListPosn++, valsxp);
    names.push_back(name);
}

void RcppFunction::appendToRList(std::string name, std::string value) {
    if (currListPosn < 0 || currListPosn >= listSize)
      throw std::range_error("RcppFunction::appendToRlist(string): posn out of range");
    SEXP valsxp = PROTECT(Rf_allocVector(STRSXP,1));
    numProtected++;
    SET_STRING_ELT(valsxp, 0, Rf_mkChar(value.c_str()));
    SET_VECTOR_ELT(listArg, currListPosn++, valsxp);
    names.push_back(name);
}

void RcppFunction::appendToRList(std::string name, RcppDate& date) {
    if (currListPosn < 0 || currListPosn >= listSize)
      throw std::range_error("RcppFunction::appendToRlist(RcppDate): list posn out of range");
    SEXP valsxp = PROTECT(Rf_allocVector(REALSXP,1));
    numProtected++;
    REAL(valsxp)[0] = date.getJDN() - RcppDate::Jan1970Offset;
    SEXP dateclass = PROTECT(Rf_allocVector(STRSXP, 1));
    numProtected++;
    SET_STRING_ELT(dateclass, 0, Rf_mkChar("Date"));
    Rf_setAttrib(valsxp, R_ClassSymbol, dateclass);
    SET_VECTOR_ELT(listArg, currListPosn++, valsxp);
    names.push_back(name);
}

void RcppFunction::appendToRList(std::string name, RcppDatetime& datetime) {
    if (currListPosn < 0 || currListPosn >= listSize)
      throw std::range_error("RcppFunction::appendToRlist(RcppDatetime): list posn out of range");
    SEXP valsxp = PROTECT(Rf_allocVector(REALSXP,1));
    numProtected++;
    REAL(valsxp)[0] = datetime.getFractionalTimestamp();
    SEXP datetimeclass = PROTECT(Rf_allocVector(STRSXP, 2));
    numProtected++;
    SET_STRING_ELT(datetimeclass, 0, Rf_mkChar("POSIXt"));
    SET_STRING_ELT(datetimeclass, 1, Rf_mkChar("POSIXct"));
    Rf_setAttrib(valsxp, R_ClassSymbol, datetimeclass);
    SET_VECTOR_ELT(listArg, currListPosn++, valsxp);
    names.push_back(name);
}

#include <cstring>

// Paul Roebuck has observed that the memory used by an exception message
// is not reclaimed if error() is called inside of a catch block (due to
// a setjmp() call), and he suggested the following work-around.
char *copyMessageToR(const char* const mesg) {
    char* Rmesg;
    const char* prefix = "Exception: ";
    void* Rheap = R_alloc(strlen(prefix)+strlen(mesg)+1,sizeof(char));
    Rmesg = static_cast<char*>(Rheap);
    strcpy(Rmesg, prefix);
    strcat(Rmesg, mesg);
    return Rmesg;
}


Generated by  Doxygen 1.6.0   Back to index