[Rcpp-commits] r4297 - in pkg/Rcpp: . src

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

Author: edd
Date: 2013-03-29 17:19:30 +0100 (Fri, 29 Mar 2013)
New Revision: 4297

Modified:
   pkg/Rcpp/ChangeLog
   pkg/Rcpp/DESCRIPTION
   pkg/Rcpp/src/api.cpp
Log:
api.cpp: Re-enable coerce_to_string<>() for real and complex types with Poor Man's
  Versions (TM) of Rf_EncodeReal and Rf_EncodeComplex which the Powers That Be
  disallow from being used
DESCRIPTION: Call it 0.10.3.1


Modified: pkg/Rcpp/ChangeLog
===================================================================
--- pkg/Rcpp/ChangeLog	2013-03-29 13:37:50 UTC (rev 4296)
+++ pkg/Rcpp/ChangeLog	2013-03-29 16:19:30 UTC (rev 4297)
@@ -1,3 +1,9 @@
+2013-03-29  Dirk Eddelbuettel  <edd at debian.org>
+
+	* src/api.cpp (Rcpp): Re-enable coerce_to_string<>() for real and
+	complex types with Poor Man's Versions (TM) of Rf_EncodeReal and
+	Rf_EncodeComplex which the Powers That Be disallow from being used
+
 2013-03-29 Romain Francois <romain at r-enthusiasts.com>
 
         * include/Rcpp/traits/named_object.h: only keep named_object<SEXP>
@@ -4,13 +10,14 @@
         * include/Rcpp/Named.h: Named generates named_object<SEXP>
         * include/Rcpp/api/meat/DottedPair.h: adapt to changes above
         * include/Rcpp/DottedPair.h: idem
-        * src/api.cpp: define DottedPair::Proxy::operator=( named_object<SEXP> )
+        * src/api.cpp: define DottedPair::Proxy::operator=(
+	named_object<SEXP> )
 
 2013-03-27 Romain Francois <romain at r-enthusiasts.com>
 
-        * include/Rcpp/vector/MatrixRow.h : removed unintended printed messaged
-        (reported on Rcpp-devel by Michaeal Love)
-        
+        * include/Rcpp/vector/MatrixRow.h : removed unintended printed
+	messaged (reported on Rcpp-devel by Michaeal Love)
+
 2013-03-23  Dirk Eddelbuettel  <edd at debian.org>
 
         * DESCRIPTION: Release 0.10.3

Modified: pkg/Rcpp/DESCRIPTION
===================================================================
--- pkg/Rcpp/DESCRIPTION	2013-03-29 13:37:50 UTC (rev 4296)
+++ pkg/Rcpp/DESCRIPTION	2013-03-29 16:19:30 UTC (rev 4297)
@@ -1,6 +1,6 @@
 Package: Rcpp
 Title: Seamless R and C++ Integration
-Version: 0.10.3
+Version: 0.10.3.1
 Date: $Date$
 Author: Dirk Eddelbuettel and Romain Francois, with contributions 
  by Douglas Bates, John Chambers and JJ Allaire

Modified: pkg/Rcpp/src/api.cpp
===================================================================
--- pkg/Rcpp/src/api.cpp	2013-03-29 13:37:50 UTC (rev 4296)
+++ pkg/Rcpp/src/api.cpp	2013-03-29 16:19:30 UTC (rev 4297)
@@ -3,7 +3,7 @@
 //
 // api.cpp: Rcpp R/C++ interface class library -- Rcpp api
 //
-// Copyright (C) 2012 - 2013 Dirk Eddelbuettel and Romain Francois
+// Copyright (C) 2012 - 2013  Dirk Eddelbuettel and Romain Francois
 //
 // This file is part of Rcpp.
 //
@@ -1706,37 +1706,53 @@
     return buffer ;    
 }
 
-// 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;
-// }
+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 <> const char* coerce_to_string<REALSXP>(double x){
-//     int w,d,e ;
-//     Rf_formatReal( &x, 1, &w, &d, &e, 0 ) ;
-//     char* tmp = const_cast<char*>( Rf_EncodeReal(x, w, d, e, '.') );
-// 	return dropTrailing0(tmp, '.');
-        
-// }
-// template <> const char* coerce_to_string<CPLXSXP>(Rcomplex x){
-//     int wr, dr, er, wi, di, ei;
-//     Rf_formatComplex(&x, 1, &wr, &dr, &er, &wi, &di, &ei, 0);
-//     return Rf_EncodeComplex(x, wr, dr, er, wi, di, ei, '.' );
-// }
+template <> const char* coerce_to_string<REALSXP>(double x){
+    int w,d,e ;
+    // cf src/main/format.c in R's sources:
+    //   The return values are
+    //     w : the required field width
+    //     d : use %w.df in fixed format, %#w.de in scientific format
+    //     e : use scientific format if != 0, value is number of exp digits - 1
+    //
+    //   nsmall specifies the minimum number of decimal digits in fixed format:
+    //   it is 0 except when called from do_format.
+    Rf_formatReal( &x, 1, &w, &d, &e, 0 ) ;
+    // we are no longer allowed to use this:
+    //     char* tmp = const_cast<char*>( Rf_EncodeReal(x, w, d, e, '.') );
+    // so approximate it poorly as
+    static char tmp[128];
+    snprintf(tmp, 127, "%*.*f", w, d, x);
+    return dropTrailing0(tmp, '.');
+}
 
+template <> const char* coerce_to_string<CPLXSXP>(Rcomplex x){
+    int wr, dr, er, wi, di, ei;
+    Rf_formatComplex(&x, 1, &wr, &dr, &er, &wi, &di, &ei, 0);
+    // we are no longer allowed to use this:
+    //     Rf_EncodeComplex(x, wr, dr, er, wi, di, ei, '.' );
+    // so approximate it poorly as
+    static char tmp[128];
+    snprintf(tmp, 127, "%*.*f+%*.*fi", wr, dr, x.r, wi, di, x.i);
+    return tmp;
+}
 
 } // internal
 } // Rcpp