[Rcpp-commits] r197 - in pkg: R inst inst/examples/RcppInline

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

Author: edd
Date: 2009-12-18 17:12:43 +0100 (Fri, 18 Dec 2009)
New Revision: 197

Added:
   pkg/inst/examples/RcppInline/RcppSimpleExample.r
Modified:
   pkg/R/RcppInline.R
   pkg/inst/ChangeLog
Log:
another fix for Rcpp use: only only the Rcpp header (and hence NO_REMAP) and catch that for warning()
another simple example function

Modified: pkg/R/RcppInline.R
===================================================================
--- pkg/R/RcppInline.R	2009-12-18 02:09:45 UTC (rev 196)
+++ pkg/R/RcppInline.R	2009-12-18 16:12:43 UTC (rev 197)
@@ -36,7 +36,6 @@
     stop("mismatch between the number of functions declared in 'sig' and the number of function bodies provided in 'body'")
 
   if (Rcpp) {
-      includes <- paste(includes, "\n#include <Rcpp.h>\n", sep="")
       cxxargs <- c(Rcpp:::RcppCxxFlags(), cxxargs)	# prepend information from Rcpp
       libargs <- c(Rcpp:::RcppLdFlags(), libargs)	# prepend information from Rcpp
   }
@@ -62,8 +61,10 @@
     if ( convention == ".Call" ) {
   	  ## include R includes, also error
   	  if (i == 1) {
-	      code <- paste("#include <R.h>\n#include <Rdefines.h>\n",
-	                    "#include <R_ext/Error.h>\n", sep="");
+	      code <- ifelse(Rcpp,
+                         "#include <Rcpp.h>\n",
+                         paste("#include <R.h>\n#include <Rdefines.h>\n",
+                               "#include <R_ext/Error.h>\n", sep=""));
 	      ## include further includes
 	      code <- paste(c(code, includes, ""), collapse="\n")
 	      ## include further definitions
@@ -83,14 +84,16 @@
   	  ## add code, split lines
   	  code <- paste( code, paste(body[[i]], collapse="\n"), sep="")
   	  ## CLOSE function, add return and warning in case the user forgot it
-  	  code <- paste( code, "\n  warning(\"your C program does not return anything!\");\n  return R_NilValue;\n}\n", sep="");
+  	  code <- paste(code, "\n  ",
+                    ifelse(Rcpp, "Rf_warning", "warning"),
+                    "(\"your C program does not return anything!\");\n  return R_NilValue;\n}\n", sep="");
     }
 
     ## C/C++ with .C convention ************************************************
     else if ( convention == ".C" ) {
   	  if (i == 1) {
 	      ## include only basic R includes
-	      code <- "#include <R.h>\n"
+	      code <- ifelse(Rcpp,"#include <Rcpp.h>\n", "#include <R.h>\n")
 	      ## include further includes
 	      code <- paste(c(code, includes, ""), collapse="\n")
 	      ## include further definitions

Modified: pkg/inst/ChangeLog
===================================================================
--- pkg/inst/ChangeLog	2009-12-18 02:09:45 UTC (rev 196)
+++ pkg/inst/ChangeLog	2009-12-18 16:12:43 UTC (rev 197)
@@ -1,3 +1,8 @@
+2009-12-18  Dirk Eddelbuettel  <edd at debian.org>
+
+	* R/RcppInline.R: Another improvement for Rcpp use
+        * inst/examples/RcppInline/RcppSimpleExamples.r: Another simple case
+
 2009-12-17  Dirk Eddelbuettel  <edd at debian.org>
 
 	* R/RcppInline.R: Improved / simplified in light of getting it to

Added: pkg/inst/examples/RcppInline/RcppSimpleExample.r
===================================================================
--- pkg/inst/examples/RcppInline/RcppSimpleExample.r	                        (rev 0)
+++ pkg/inst/examples/RcppInline/RcppSimpleExample.r	2009-12-18 16:12:43 UTC (rev 197)
@@ -0,0 +1,26 @@
+#!/usr/bin/r
+
+
+suppressMessages(library(Rcpp))
+
+
+foo <- '
+  int i, j, na, nb, nab;
+  double *xa, *xb, *xab;
+  SEXP ab;
+
+  PROTECT(a = AS_NUMERIC(a));
+  PROTECT(b = AS_NUMERIC(b));
+  na = LENGTH(a); nb = LENGTH(b); nab = na + nb - 1;
+  PROTECT(ab = NEW_NUMERIC(nab));
+  xa = NUMERIC_POINTER(a); xb = NUMERIC_POINTER(b);
+  xab = NUMERIC_POINTER(ab);
+  for(i = 0; i < nab; i++) xab[i] = 0.0;
+  for(i = 0; i < na; i++)
+    for(j = 0; j < nb; j++) xab[i + j] += xa[i] * xb[j];
+  UNPROTECT(3);
+  return(ab);
+'
+
+funx <- cfunction(signature(a="numeric",b="numeric"), foo, Rcpp=FALSE, verbose=FALSE)
+funx(a=1:20, b=2:11)