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

noreply at r-forge.r-project.org noreply at r-forge.r-project.org
Sun Dec 13 20:34:26 CET 2009


Author: edd
Date: 2009-12-13 20:34:26 +0100 (Sun, 13 Dec 2009)
New Revision: 188

Added:
   pkg/inst/examples/RcppInline/RcppInlineWithLibsExamples.r
Modified:
   pkg/R/RcppInline.R
   pkg/inst/ChangeLog
Log:
extend cfunction [ from the inline package ] to allow for arbitrary headers and library
added second example showing how to use that with simple gsl example


Modified: pkg/R/RcppInline.R
===================================================================
--- pkg/R/RcppInline.R	2009-12-13 19:28:36 UTC (rev 187)
+++ pkg/R/RcppInline.R	2009-12-13 19:34:26 UTC (rev 188)
@@ -14,7 +14,8 @@
 # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 cfunction <- function(sig=character(), body=character(), includes=character(), otherdefs=character(),
                       language=c("C++", "C", "Fortran", "F95", "ObjectiveC", "ObjectiveC++"),
-                      verbose=FALSE, convention=c(".Call", ".C", ".Fortran"), Rcpp=FALSE) {
+                      verbose=FALSE, convention=c(".Call", ".C", ".Fortran"), Rcpp=FALSE,
+                      compileargs=character(), linkargs=character()) {
 
   convention <- match.arg(convention)
 
@@ -36,12 +37,23 @@
 
   if (Rcpp) {
       includes <- paste(includes, "\n#include <Rcpp.h>\n", sep="")
-      cxxflags <- paste("PKG_CXXFLAGS=\"", Rcpp:::RcppCxxFlags(), "\"", sep="")
-      ldflags <- paste("PKG_LIBS=\"", Rcpp:::RcppLdFlags(), "\"", sep="")
-      pkgargs <- paste(cxxflags, ldflags, " ", sep=" ")
+      cxxflags <- paste("PKG_CXXFLAGS=\"",
+                        Rcpp:::RcppCxxFlags(), 		# information from Rcpp
+                        paste(compileargs,collapse=" "),# headers from users if any
+                        "\"", collapse=" ", sep=" ")
+      ldflags <-  paste("PKG_LIBS=\"",
+                        Rcpp:::RcppLdFlags(),
+                        paste(linkargs, collapse=" "), # libraries from users if any
+                        "\"", collapse=" ", sep=" ")
   } else {
-      pkgargs <- character()
+      cxxflags <- paste("PKG_CXXFLAGS=\"",
+                        paste(compileargs,collapse=" "),# headers from users if any
+                        "\"", sep="")
+      ldflags <-  paste("PKG_LIBS=\"",
+                        paste(linkargs, collapse=" "), # libraries from users if any
+                        "\"", sep="")
   }
+  pkgargs <-  paste(c(cxxflags, ldflags, ""), collapse=" ")
 
   ## GENERATE THE CODE
   for ( i in seq_along(sig) ) {
@@ -231,7 +243,12 @@
   if ( file.exists(libLFile) ) file.remove( libLFile )
   if ( file.exists(libLFile2) ) file.remove( libLFile2 )
 
-  compiled <- system(paste(pkgargs, R.home(component="bin"), "/R CMD SHLIB ", libCFile, sep=""), intern=!verbose)
+  cmd <- paste(pkgargs, R.home(component="bin"), "/R CMD SHLIB ", libCFile, sep="")
+  if (verbose) {
+      cat("Compilation argument:\n")
+      cat(" ", cmd)
+  }
+  compiled <- system(cmd, intern=!verbose)
 
   if ( !file.exists(libLFile) && file.exists(libLFile2) ) libLFile <- libLFile2
   if ( !file.exists(libLFile) ) {

Modified: pkg/inst/ChangeLog
===================================================================
--- pkg/inst/ChangeLog	2009-12-13 19:28:36 UTC (rev 187)
+++ pkg/inst/ChangeLog	2009-12-13 19:34:26 UTC (rev 188)
@@ -1,3 +1,10 @@
+2009-12-13  Dirk Eddelbuettel  <edd at debian.org>
+
+	* R/RcppInline.R: Extended to for additional header and library
+	  arguments so that we can work with arbitrary other projects
+        * inst/examples/RcppInline/RcppInlineWithLibsExamples.r: New
+	  examples using GNU GSL to show how to compile + link via inline
+
 2009-12-11  Dirk Eddelbuettel  <edd at debian.org>
 
 	* R/RcppInline.R: Imported function 'cfunction' from the inline
@@ -7,7 +14,7 @@
         * man/RcppInline.Rd: Imported from inline, plus change for Rcpp
         * inst/examples/RcppInline/RcppInlineExample.r: Small example
 	  taken from the 'Intro to HPC with R' tutorials
-	
+
 	* R/RcppVersion.R: Removed as unused as redundant given read.dcf() in R
 	* man/RcppVersion.R: idem
 	* NAMESPACE: updated accordingly

Added: pkg/inst/examples/RcppInline/RcppInlineWithLibsExamples.r
===================================================================
--- pkg/inst/examples/RcppInline/RcppInlineWithLibsExamples.r	                        (rev 0)
+++ pkg/inst/examples/RcppInline/RcppInlineWithLibsExamples.r	2009-12-13 19:34:26 UTC (rev 188)
@@ -0,0 +1,137 @@
+#!/usr/bin/r
+
+suppressMessages(library(Rcpp))
+
+firstExample <- function() {
+    ## a really simple C program calling three functions from the GSL
+    gslrng <- '
+    gsl_rng *r;
+    gsl_rng_env_setup();
+    double v;
+
+    r = gsl_rng_alloc (gsl_rng_default);
+
+    printf("generator type: %s\\n", gsl_rng_name (r));
+    printf("seed = %lu\\n", gsl_rng_default_seed);
+    v = gsl_rng_get (r);
+    printf("first value = %f\\n", v);
+    return R_NilValue;
+    '
+
+    ## turn into a function that R can call
+    ## compileargs redundant on Debian/Ubuntu as gsl headers are found anyway
+    funx <- cfunction(signature(ignored="numeric"), gslrng,
+                      includes="#include <gsl/gsl_rng.h>",
+                      Rcpp=FALSE,
+                      compileargs="-I/usr/include",
+                      linkargs="-lgsl -lgslcblas")
+
+    cat("Calling first example\n")
+    funx(0)
+    invisible(NULL)
+}
+
+secondExample <- function() {
+
+    ## now use Rcpp to pass down a parameter for the seed
+    gslrng <- '
+    RcppVector<int> vec(par);
+    int seed = vec(0);
+
+    gsl_rng *r;
+    gsl_rng_env_setup();
+    double v;
+
+    r = gsl_rng_alloc (gsl_rng_default);
+
+    gsl_rng_set (r, (unsigned long) seed);
+    v = gsl_rng_get (r);
+
+    #ifndef BeSilent
+    printf("generator type: %s\\n", gsl_rng_name (r));
+    printf("seed = %d\\n", seed);
+    printf("first value = %f\\n", v);
+    #endif
+
+    RcppResultSet rs;           // Build result set to be returned as a list to R.
+    rs.add("value", v);         // vec as named element with name "vec"
+    SEXP rl = rs.getReturnList();    // Get the list to be returned to R.
+
+    return rl;
+    '
+
+    ## turn into a function that R can call
+    ## compileargs redundant on Debian/Ubuntu as gsl headers are found anyway
+    ## use additional define for compile to suppress output
+    funx <- cfunction(signature(par="numeric"), gslrng,
+                      includes="#include <gsl/gsl_rng.h>",
+                      Rcpp=TRUE,
+                      compileargs="-I/usr/include",
+                      linkargs="-lgsl -lgslcblas")
+    cat("\n\nCalling second example without -DBeSilent set\n")
+    print(funx(0)["value"])
+
+    funx <- cfunction(signature(par="numeric"), gslrng,
+                      includes="#include <gsl/gsl_rng.h>",
+                      Rcpp=TRUE,
+                      compileargs="-I/usr/include -DBeSilent",
+                      linkargs="-lgsl -lgslcblas")
+    cat("\n\nCalling second example with -DBeSilent set\n")
+    print(funx(1)["value"])
+
+    invisible(NULL)
+}
+
+thirdExample <- function() {
+
+    ## now use Rcpp to pass down a parameter for the seed
+    gslrng <- '
+    RcppVector<int> vec(par);
+    int seed = vec(0);
+
+    gsl_rng *r;
+    gsl_rng_env_setup();
+    double v;
+
+    r = gsl_rng_alloc (gsl_rng_default);
+
+    gsl_rng_set (r, (unsigned long) seed);
+    v = gsl_rng_get (r);
+
+    #ifndef BeSilent
+    printf("generator type: %s\\n", gsl_rng_name (r));
+    printf("seed = %d\\n", seed);
+    printf("first value = %f\\n", v);
+    #endif
+
+    RcppResultSet rs;           // Build result set to be returned as a list to R.
+    rs.add("value", v);         // vec as named element with name "vec"
+    SEXP rl = rs.getReturnList();    // Get the list to be returned to R.
+
+    return rl;
+    '
+
+    ## turn into a function that R can call
+    ## compileargs redundant on Debian/Ubuntu as gsl headers are found anyway
+    ## use additional define for compile to suppress output
+    funx <- cfunction(signature(par="numeric"), gslrng,
+                      includes="#include <gsl/gsl_rng.h>",
+                      Rcpp=TRUE,
+                      compileargs="-I/usr/include",
+                      linkargs="-lgsl -lgslcblas")
+    cat("\n\nCalling second example without -DBeSilent set\n")
+    print(funx(0)["value"])
+
+    funx <- cfunction(signature(par="numeric"), gslrng,
+                      includes="#include <gsl/gsl_rng.h>",
+                      Rcpp=TRUE,
+                      compileargs="-I/usr/include -DBeSilent",
+                      linkargs="-lgsl -lgslcblas")
+    cat("\n\nCalling second example with -DBeSilent set\n")
+    print(funx(1)["value"])
+
+    invisible(NULL)
+}
+
+firstExample()
+secondExample()


Property changes on: pkg/inst/examples/RcppInline/RcppInlineWithLibsExamples.r
___________________________________________________________________
Name: svn:executable
   + *



More information about the Rcpp-commits mailing list