[Rcpp-commits] r4022 - in pkg/Rcpp: . inst/include/Rcpp/internal src

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

Author: romain
Date: 2012-11-22 23:56:05 +0100 (Thu, 22 Nov 2012)
New Revision: 4022

Modified:
   pkg/Rcpp/TODO
   pkg/Rcpp/inst/include/Rcpp/internal/r_coerce.h
   pkg/Rcpp/src/coerce.cpp
Log:
added r_coerce<.,STRSXP> functions

Modified: pkg/Rcpp/TODO
===================================================================
--- pkg/Rcpp/TODO	2012-11-22 20:08:42 UTC (rev 4021)
+++ pkg/Rcpp/TODO	2012-11-22 22:56:05 UTC (rev 4022)
@@ -46,18 +46,13 @@
 API
 
     o   Rcpp::Factor and Rcpp::Ordered
-    
-    o   const operators, as requested on Rcpp-devel:
-        http://permalink.gmane.org/gmane.comp.lang.r.rcpp/494
 
     o   Fast indexing and g++ 4.5.0 or later: open issue of why this compiler
         gets upset when the previous version(s) coped just fine
 
 Modules 
         
-    o   Class inheritance. If we have Foo and Bar : public Foo, and we expose
-        both Foo and Bar to R, R level class Bar should enjoy methods of Foo
-        and the S4 inheritance should reflect the C++ level inheritance
+    o   Class inheritance. Reflect C++ inheritance at the R level. 
         
 Syntactic sugar
 
@@ -73,13 +68,9 @@
 
     o 	crossprod
 	
-    o	SUGAR_MATH: is there overhead in having the function pointer, should
-	the macro generate code that statically calls the function ? It would 
-	probably be harder to write/debug
-		
     o	Vector * Matrix, Matrix * Matrix
 
-    o   duplicated, unique, count, sum
+    o   duplicated, count
     
     o   operator% 
     

Modified: pkg/Rcpp/inst/include/Rcpp/internal/r_coerce.h
===================================================================
--- pkg/Rcpp/inst/include/Rcpp/internal/r_coerce.h	2012-11-22 20:08:42 UTC (rev 4021)
+++ pkg/Rcpp/inst/include/Rcpp/internal/r_coerce.h	2012-11-22 22:56:05 UTC (rev 4022)
@@ -3,7 +3,7 @@
 //
 // r_coerce.h: Rcpp R/C++ interface class library -- coercion
 //
-// Copyright (C) 2010 - 2011 Dirk Eddelbuettel and Romain Francois
+// Copyright (C) 2010 - 2012 Dirk Eddelbuettel and Romain Francois
 //
 // This file is part of Rcpp.
 //
@@ -68,7 +68,16 @@
 template <> Rcomplex r_coerce<RAWSXP,CPLXSXP>(Rbyte from);
 template <> Rcomplex r_coerce<LGLSXP,CPLXSXP>(int from) ;
 
+// -> STRSXP
+template <> inline SEXP r_coerce<STRSXP ,STRSXP>(SEXP from){ return from ; }
+template <> SEXP r_coerce<CPLXSXP,STRSXP>(Rcomplex from) ;
+template <> SEXP r_coerce<REALSXP,STRSXP>(double from) ;
+template <> SEXP r_coerce<INTSXP ,STRSXP>(int from);
+template <> SEXP r_coerce<RAWSXP ,STRSXP>(Rbyte from);
+template <> SEXP r_coerce<LGLSXP ,STRSXP>(int from) ;
 
+
+
 } // internal
 } // Rcpp
 

Modified: pkg/Rcpp/src/coerce.cpp
===================================================================
--- pkg/Rcpp/src/coerce.cpp	2012-11-22 20:08:42 UTC (rev 4021)
+++ pkg/Rcpp/src/coerce.cpp	2012-11-22 22:56:05 UTC (rev 4022)
@@ -2,7 +2,7 @@
 //
 // coerce.cpp: Rcpp R/C++ interface class library -- coercion
 //
-// Copyright (C) 2010 - 2011 Dirk Eddelbuettel and Romain Francois
+// Copyright (C) 2010 - 2012 Dirk Eddelbuettel and Romain Francois
 //
 // This file is part of Rcpp.
 //
@@ -21,6 +21,8 @@
 
 #include <RcppCommon.h>
 
+#include <R_ext/PrtUtil.h>
+
 namespace Rcpp{ 
 namespace internal{
 
@@ -136,7 +138,63 @@
 	return c ;
 }
 
+inline int integer_width( int n ){
+    return n < 0 ? ( (int) ( log10( -n+0.5) + 2 ) ) : ( (int) ( log10( n+0.5) + 1 ) ) ;    
+}
 
+#define NB 1000
+template <> SEXP r_coerce<INTSXP ,STRSXP>(int from){
+    static char buffer[NB] ;
+    if( from == NA_INTEGER ) return NA_STRING ;
+    snprintf( buffer, NB, "%*d", integer_width(from), from );
+    return Rf_mkChar(buffer) ;
+}
+template <> SEXP r_coerce<LGLSXP ,STRSXP>(int from){
+    return from == NA_LOGICAL ? NA_STRING : (from == 0 ? Rf_mkChar("FALSE") : Rf_mkChar("TRUE") ) ;    
+}
+template <> SEXP r_coerce<RAWSXP ,STRSXP>(Rbyte from){
+    char buff[3];
+    ::sprintf(buff, "%02x", from);
+    return Rf_mkChar( buff ) ;    
+}
+
+
+static const char* dropTrailing0(char *s, char cdec) {
+    /* Note that  's'  is modified */
+    char *p = s;
+    for (p = s; *p; p++) {
+	if(*p == cdec) {
+	    char *replace = p++;
+	    while ('0' <= *p  &&  *p <= '9')
+		if(*(p++) != '0')
+		    replace = p;
+	    if(replace != p)
+		while((*(replace++) = *(p++)))
+		    ;
+	    break;
+	}
+    }
+    return s;
+}
+
+template <> SEXP r_coerce<REALSXP,STRSXP>(double x){
+    if( Rcpp::traits::is_na<REALSXP>( x ) ) return NA_STRING ;
+    
+    int w,d,e ;
+    Rf_formatReal( &x, 1, &w, &d, &e, 0 ) ;
+    char* tmp = const_cast<char*>( Rf_EncodeReal(x, w, d, e, '.') );
+	return Rf_mkChar(dropTrailing0(tmp, '.'));
+        
+}
+template <> SEXP r_coerce<CPLXSXP,STRSXP>(Rcomplex x){
+    if( Rcpp::traits::is_na<CPLXSXP>(x) ) return NA_STRING ;
+    
+    int wr, dr, er, wi, di, ei;
+    Rf_formatComplex(&x, 1, &wr, &dr, &er, &wi, &di, &ei, 0);
+    return Rf_mkChar( Rf_EncodeComplex(x, wr, dr, er, wi, di, ei, '.' ));
+}
+
+
 } // internal
 } // Rcpp