Merge pull request #535 from coatless/modernizing-fastlm

Modernizing fastlm and functionCallback

Author: eddelbuettel

ChangeLog

@@ -1,3 +1,15 @@
+2016-08-05  James J Balamuta  <[email protected]>
+
+        * inst/examples/FastLM/fastLMviaArmadillo.r: format fix
+        * inst/examples/FastLM/lmGSL.R: Updated example to use 
+        Rcpp attributes instead of cxxfunction
+        * inst/examples/FastLM/lmArmadillo.R: Idem
+        * inst/examples/functionCallback/newApiExample.r: Idem
+        * inst/examples/RcppInline/RcppInlineExample.r: Idem
+        * inst/examples/RcppInline/RcppInlineWithLibsExamples.r: Idem
+        * inst/examples/RcppInline/UncaughtExceptions.r: Idem
+        * inst/examples/RcppInline/external_pointer.r: Idem
+
 2016-08-04  James J Balamuta  <[email protected]>
 
         * src/attributes.cpp: Correct variable re-declaration

inst/NEWS.Rd

@@ -31,7 +31,8 @@
     \itemize{
       \item Examples that used cxxfunction() from the inline package have been
       rewritten to use either sourceCpp() or cppFunction() 
-      (James Balamuta in \ghpr{532} addressing issue \ghit{56}).
+      (James Balamuta in \ghpr{535}, \ghpr{534}, and \ghpr{532} 
+      addressing issue \ghit{56}).
     }
   }
 }

inst/examples/FastLM/fastLMviaArmadillo.r

@@ -27,8 +27,8 @@ checkLmArmadillo <- function(y, X) {
     fun <- lmArmadillo()
     res <- fun(y, X)
     fit <- lm(y ~ X - 1)
-    rc <- all.equal( res[[1]], as.numeric(coef(fit))) &
-          all.equal( res[[2]], as.numeric(coef(summary(fit))[,2]))
+    rc <- all.equal( as.numeric(res[[1]]), as.numeric(coef(fit))) &
+          all.equal( as.numeric(res[[2]]), as.numeric(coef(summary(fit))[,2]))
     invisible(rc)
 }
 

inst/examples/FastLM/lmArmadillo.R

@@ -19,9 +19,14 @@
 # along with Rcpp.  If not, see <http://www.gnu.org/licenses/>.
 
 suppressMessages(require(Rcpp))
+
+## NOTE: This is the old way to compile Rcpp code inline.
+## The code here has left as a historical artifact and tribute to the old way.
+## Please use the code under the "new" inline compilation section.
+
 suppressMessages(require(inline))
 
-lmArmadillo <- function() {
+lmArmadillo_old <- function() {
     src <- '
 
     Rcpp::NumericVector yr(Ysexp);
@@ -49,9 +54,36 @@ lmArmadillo <- function() {
     '
 
     ## turn into a function that R can call
-    fun <- cxxfunction(signature(Ysexp="numeric", Xsexp="numeric"),
+    fun_old <- cxxfunction(signature(Ysexp="numeric", Xsexp="numeric"),
                        src,
                        includes="#include <armadillo>",
                        plugin="RcppArmadillo")
 }
 
+
+## NOTE: Within this section, the new way to compile Rcpp code inline has been
+## written. Please use the code next as a template for your own project.
+
+lmArmadillo <- function() {
+
+    sourceCpp(code='
+    #include <RcppArmadillo.h>
+    // [[Rcpp::depends(RcppArmadillo)]]
+          
+    // [[Rcpp::export]]
+    Rcpp::List fun(const arma::vec & y, const arma::mat & X){
+
+        int n = X.n_rows, k = X.n_cols;
+    
+        arma::vec coef = solve(X, y);		// fit model y ~ X
+    
+        arma::vec resid = y - X*coef;    	// to compute std. error of the coefficients
+        double sig2 = arma::as_scalar(trans(resid)*resid)/(n-k);	// requires Armadillo 0.8.2 or later
+        arma::mat covmat = sig2 * arma::inv(arma::trans(X)*X);
+    
+        return Rcpp::List::create( Rcpp::Named( "coefficients") = coef,
+                                   Rcpp::Named( "stderr") = sqrt(arma::diagvec(covmat)));
+    }')
+    
+    fun
+}

inst/examples/FastLM/lmGSL.R

@@ -19,9 +19,14 @@
 # along with Rcpp.  If not, see <http://www.gnu.org/licenses/>.
 
 suppressMessages(require(Rcpp))
+
+## NOTE: This is the old way to compile Rcpp code inline.
+## The code here has left as a historical artifact and tribute to the old way.
+## Please use the code under the "new" inline compilation section.
+
 suppressMessages(require(inline))
 
-lmGSL <- function() {
+lmGSL_old <- function() {
 
     src <- '
 
@@ -62,8 +67,55 @@ lmGSL <- function() {
 
     ## turn into a function that R can call
     ## compileargs redundant on Debian/Ubuntu as gsl headers are found anyway
-    fun <- cxxfunction(signature(Ysexp="numeric", Xsexp="numeric"),
+    fun_old <- cxxfunction(signature(Ysexp="numeric", Xsexp="numeric"),
                        src,
                        includes="#include <gsl/gsl_multifit.h>",
                        plugin="RcppGSL")
 }
+
+## NOTE: Within this section, the new way to compile Rcpp code inline has been
+## written. Please use the code next as a template for your own project.
+
+lmGSL <- function() {
+    
+sourceCpp(code='
+#include <RcppGSL.h>
+#include <gsl/gsl_multifit.h>
+// [[Rcpp::depends(RcppGSL)]]
+
+// [[Rcpp::export]]
+Rcpp::List fun(Rcpp::NumericVector Yr, Rcpp::NumericMatrix Xr){
+    
+    int i,j,n = Xr.nrow(), k = Xr.ncol();
+    double chisq;
+    
+    gsl_matrix *X = gsl_matrix_alloc (n, k);
+    gsl_vector *y = gsl_vector_alloc (n);
+    gsl_vector *c = gsl_vector_alloc (k);
+    gsl_matrix *cov = gsl_matrix_alloc (k, k);
+    for (i = 0; i < n; i++) {
+        for (j = 0; j < k; j++)
+            gsl_matrix_set (X, i, j, Xr(i,j));
+        gsl_vector_set (y, i, Yr(i));
+    }
+    
+    gsl_multifit_linear_workspace *work = gsl_multifit_linear_alloc (n, k);
+    gsl_multifit_linear (X, y, c, cov, &chisq, work);
+    gsl_multifit_linear_free (work);
+    
+    Rcpp::NumericVector coefr(k), stderrestr(k);
+    for (i = 0; i < k; i++) {
+        coefr(i) = gsl_vector_get(c,i);
+        stderrestr(i) = sqrt(gsl_matrix_get(cov,i,i));
+    }
+    gsl_matrix_free (X);
+    gsl_vector_free (y);
+    gsl_vector_free (c);
+    gsl_matrix_free (cov);
+    
+    
+    return Rcpp::List::create( Rcpp::Named( "coef", coefr),
+                               Rcpp::Named( "stderr", stderrestr));
+}')
+fun
+}

inst/examples/functionCallback/newApiExample.r

@@ -1,7 +1,6 @@
 #!/usr/bin/env r
 
 suppressMessages(library(Rcpp))
-suppressMessages(library(inline))
 
 # R function that will be called from C++
 vecfunc <- function(x) {
@@ -12,6 +11,12 @@ vecfunc <- function(x) {
     return(y)
 }
 
+## NOTE: This is the old way to compile Rcpp code inline.
+## The code here has left as a historical artifact and tribute to the old way.
+## Please use the code under the "new" inline compilation section.
+
+suppressMessages(library(inline))
+
 # C++ source code to operate on function and vector
 cpp <- '
 	int n = as<int>(N);
@@ -27,6 +32,20 @@ cpp <- '
 funx <- cxxfunction(signature(N = "integer" , xvec = "numeric", fun = "function" ),
                     body=cpp, include = "using namespace Rcpp; ", plugin = "Rcpp")
 
+
+## NOTE: Within this section, the new way to compile Rcpp code inline has been
+## written. Please use the code next as a template for your own project.
+
+# C++ source code to operate on function and vector
+cppFunction('
+NumericVector funx(int n, NumericVector numvec, Function f){
+    for( int i = 0; i < n; i++ ){
+       numvec = f( numvec ) ;
+    }
+    return numvec ;
+}')
+
+
 # create the vector
 xvec <- sqrt(c(1:12, 11:1))