[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