[Rcpp-commits] r2400 - in pkg: . Irwls Irwls/R Irwls/man Irwls/src Irwls/tests
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sat Nov 6 02:07:24 CET 2010
Author: jmc
Date: 2010-11-06 02:07:23 +0100 (Sat, 06 Nov 2010)
New Revision: 2400
Added:
pkg/Irwls/
pkg/Irwls/DESCRIPTION
pkg/Irwls/NAMESPACE
pkg/Irwls/R/
pkg/Irwls/R/zzz.R
pkg/Irwls/man/
pkg/Irwls/man/Irwls-package.Rd
pkg/Irwls/src/
pkg/Irwls/src/Makevars
pkg/Irwls/src/Makevars.win
pkg/Irwls/src/irwls.cpp
pkg/Irwls/src/irwls.h
pkg/Irwls/tests/
pkg/Irwls/tests/trivial.R
Log:
initial version
Added: pkg/Irwls/DESCRIPTION
===================================================================
--- pkg/Irwls/DESCRIPTION (rev 0)
+++ pkg/Irwls/DESCRIPTION 2010-11-06 01:07:23 UTC (rev 2400)
@@ -0,0 +1,16 @@
+Package: Irwls
+Type: Package
+Title: Iteratively Re-Weighted Least Squares
+Version: 1.0
+Date: 2010-11-03
+Author: John Chambers
+Maintainer: John Chambers <jmc at r-project.org>
+Description: A class based on C++ code for least-squares fitting and
+ a module exposing the C++ class through the Rcpp package
+ provides least-squares fits for varying weights, with a given
+ response vector and model matrix.
+License: GPL(>=2)
+LazyLoad: yes
+Depends: Rcpp (>= 0.8.7.1), RcppArmadillo (>= 0.2.8), methods
+LinkingTo: Rcpp, RcppArmadillo
+SystemRequirements: GNU make
Added: pkg/Irwls/NAMESPACE
===================================================================
--- pkg/Irwls/NAMESPACE (rev 0)
+++ pkg/Irwls/NAMESPACE 2010-11-06 01:07:23 UTC (rev 2400)
@@ -0,0 +1,3 @@
+useDynLib(Irwls)
+exportPattern("^[[:alpha:]]+")
+importClassesFrom( Rcpp, "C++Object", "C++Class", "Module" )
Added: pkg/Irwls/R/zzz.R
===================================================================
--- pkg/Irwls/R/zzz.R (rev 0)
+++ pkg/Irwls/R/zzz.R 2010-11-06 01:07:23 UTC (rev 2400)
@@ -0,0 +1,14 @@
+
+# grab the namespace
+.NAMESPACE <- environment()
+
+# dummy module, will be replace later
+mIrwls <- new( "Module" )
+
+.onLoad <- function(pkgname, libname){
+ # load the module and store it in our namespace
+ unlockBinding( "mIrwls" , .NAMESPACE )
+ assign( "mIrwls", Module( "mIrwls" ), .NAMESPACE )
+ lockBinding( "mIrwls", .NAMESPACE )
+}
+
Added: pkg/Irwls/man/Irwls-package.Rd
===================================================================
--- pkg/Irwls/man/Irwls-package.Rd (rev 0)
+++ pkg/Irwls/man/Irwls-package.Rd 2010-11-06 01:07:23 UTC (rev 2400)
@@ -0,0 +1,20 @@
+\name{Irwls-package}
+\alias{Irwls-package}
+\alias{Irwls}
+\docType{package}
+\title{
+Iteratively re-weighted least squares using C++
+}
+\description{
+As a demonstration of C++ classes exposed through the Rcpp package,
+this package creates a reference class to generate repeated
+least-squares fits. The class is created with a response variable and
+a fully-specified model matrix; fits are then generated with varying
+weight vectors. The design is that this package can be used by any
+form of model-fitting that eventually uses re-weighted least squares.
+}
+\author{
+John Chambers <jmc at r-project.org>
+}
+\keyword{ package }
+
Added: pkg/Irwls/src/Makevars
===================================================================
--- pkg/Irwls/src/Makevars (rev 0)
+++ pkg/Irwls/src/Makevars 2010-11-06 01:07:23 UTC (rev 2400)
@@ -0,0 +1,3 @@
+## Use the R_HOME indirection to support installations of multiple R version
+PKG_LIBS = $(shell $(R_HOME)/bin/Rscript -e "Rcpp:::LdFlags()" ) $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS)
+
Added: pkg/Irwls/src/Makevars.win
===================================================================
--- pkg/Irwls/src/Makevars.win (rev 0)
+++ pkg/Irwls/src/Makevars.win 2010-11-06 01:07:23 UTC (rev 2400)
@@ -0,0 +1,5 @@
+
+## This assume that we can call Rscript to ask Rcpp about its locations
+## Use the R_HOME indirection to support installations of multiple R version
+PKG_LIBS = $(shell $(R_HOME)/bin/Rscript.exe -e "Rcpp:::LdFlags()") $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS)
+
Added: pkg/Irwls/src/irwls.cpp
===================================================================
--- pkg/Irwls/src/irwls.cpp (rev 0)
+++ pkg/Irwls/src/irwls.cpp 2010-11-06 01:07:23 UTC (rev 2400)
@@ -0,0 +1,66 @@
+
+#include "Irwls.h"
+
+using namespace Rcpp ;
+
+class Irwls{
+public:
+ NumericMatrix x, xw;
+ NumericVector y, yw, wrt;
+
+ Irwls(SEXP xr, SEXP yr) {
+ x = NumericMatrix(xr);
+ y = NumericVector(yr);
+ xw = NumericMatrix(x.nrow(), x.ncol());
+ yw = NumericVector(y.size());
+ wrt = NumericVector(y.size());
+ }
+
+ SEXP fit(SEXP wR) {
+ compute_and_apply_weights(wR);
+ return do_fit();
+ }
+
+ SEXP do_fit() {
+ int n = xw.nrow(), p = xw.ncol();
+ arma::mat X(xw.begin(), n, p, false);
+ arma::colvec y(yw.begin(), n, false);
+ arma::vec coefa = arma::solve(X, y);
+ return wrap( coefa);
+ }
+
+ void compute_and_apply_weights(SEXP wR) {
+ int n = yw.size(), p = xw.ncol(), np = n*p;
+ NumericVector w(wR);
+ NumericIterator ir = wrt.begin(), iw = w.begin(),
+ ix = x.begin(), ixw = xw.begin(),
+ iy = y.begin(), iyw = yw.begin();
+ for (int i = 0; i < n; i++) {
+ ir[i] = sqrt(iw[i]);
+ iyw[i] = iy[i] * ir[i];
+ }
+ for (int ij = 0; ij < np; )
+ for(int i = 0; i < n; i++) {
+ ixw[ij] = ix[ij] * ir[i];
+ ij++;
+ }
+ }
+
+};
+
+RCPP_MODULE(mIrwls) {
+
+class_<Irwls>( "cppIrwls" )
+
+ .constructor(init_2<NumericMatrix,NumericVector>())
+
+ .field("x", &Irwls::x)
+ .field("y", &Irwls::y)
+ .field("xw", &Irwls::xw)
+ .field("yw", &Irwls::yw)
+ .field("wrt", &Irwls::wrt)
+
+ .method("fit", &Irwls::fit)
+ ;
+
+}
Added: pkg/Irwls/src/irwls.h
===================================================================
--- pkg/Irwls/src/irwls.h (rev 0)
+++ pkg/Irwls/src/irwls.h 2010-11-06 01:07:23 UTC (rev 2400)
@@ -0,0 +1,10 @@
+#ifndef Irwls_H
+#define Irwls_H
+
+#include <RcppArmadillo.h>
+
+typedef Rcpp::NumericVector::iterator
+ NumericIterator;
+
+
+#endif
Added: pkg/Irwls/tests/trivial.R
===================================================================
--- pkg/Irwls/tests/trivial.R (rev 0)
+++ pkg/Irwls/tests/trivial.R 2010-11-06 01:07:23 UTC (rev 2400)
@@ -0,0 +1,14 @@
+require(Irwls)
+irwls <- mIrwls$cppIrwls
+set.seed(400)
+y = rnorm(10)
+x = rnorm(10)
+xx <- cbind(rep(1,10), x, x^2)
+irxly = irwls$new(xx, y)
+coef = irxly$fit(rep(1,10))
+coef2 = lm(y ~ x + I(x^2))$coef
+stopifnot(all.equal(as.vector(coef), as.vector(coef2)))
+wt = rep(c(1,2), 5)
+coef = irxly$fit(wt)
+coef2 = lm(y ~ x + I(x^2), weights = wt)$coef
+stopifnot(all.equal(as.vector(coef), as.vector(coef2)))
More information about the Rcpp-commits
mailing list