[Rcpp-commits] r2432 - in pkg: . wls wls/R wls/man wls/src wls/tests

noreply at r-forge.r-project.org noreply at r-forge.r-project.org
Sat Nov 13 01:16:15 CET 2010


Author: jmc
Date: 2010-11-13 01:16:13 +0100 (Sat, 13 Nov 2010)
New Revision: 2432

Added:
   pkg/wls/
   pkg/wls/DESCRIPTION
   pkg/wls/NAMESPACE
   pkg/wls/R/
   pkg/wls/R/zzz.R
   pkg/wls/man/
   pkg/wls/man/mwls-module.Rd
   pkg/wls/man/wls-package.Rd
   pkg/wls/src/
   pkg/wls/src/Makevars
   pkg/wls/src/Makevars.win
   pkg/wls/src/wls.cpp
   pkg/wls/src/wls.h
   pkg/wls/tests/
   pkg/wls/tests/.Rhistory
   pkg/wls/tests/trivial.R
Removed:
   pkg/Irwls/
Log:
move Irwls to wls for better name choice; document a bit

Added: pkg/wls/DESCRIPTION
===================================================================
--- pkg/wls/DESCRIPTION	                        (rev 0)
+++ pkg/wls/DESCRIPTION	2010-11-13 00:16:13 UTC (rev 2432)
@@ -0,0 +1,16 @@
+Package: wls
+Type: Package
+Title: Iteratively Re-Weighted Least Squares 
+Version: 0.5
+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/wls/NAMESPACE
===================================================================
--- pkg/wls/NAMESPACE	                        (rev 0)
+++ pkg/wls/NAMESPACE	2010-11-13 00:16:13 UTC (rev 2432)
@@ -0,0 +1,4 @@
+useDynLib(wls)
+exportPattern("^[[:alpha:]]+")
+importFrom(Rcpp, Module)
+importClassesFrom( Rcpp, "C++Object", "C++Class", "Module" )

Added: pkg/wls/R/zzz.R
===================================================================
--- pkg/wls/R/zzz.R	                        (rev 0)
+++ pkg/wls/R/zzz.R	2010-11-13 00:16:13 UTC (rev 2432)
@@ -0,0 +1,14 @@
+
+# grab the namespace
+.NAMESPACE <- environment()
+
+# dummy module, will be replace later
+mwls <- new( "Module" )
+
+.onLoad <- function(pkgname, libname){
+	# load the module and store it in our namespace
+	unlockBinding( "mwls" , .NAMESPACE )
+	assign( "mwls",  Module( "mwls" ), .NAMESPACE )
+	lockBinding( "mwls", .NAMESPACE )
+}
+

Added: pkg/wls/man/mwls-module.Rd
===================================================================
--- pkg/wls/man/mwls-module.Rd	                        (rev 0)
+++ pkg/wls/man/mwls-module.Rd	2010-11-13 00:16:13 UTC (rev 2432)
@@ -0,0 +1,24 @@
+\name{mwls}
+\alias{mwls}
+\title{
+	Rcpp module: mwls
+}
+\description{
+	Rcpp module for weighted least-squares repeated with varying
+        weights.
+}
+\details{
+	The module contains the following items: 
+	
+	 
+	
+	classes: \describe{
+        \item{cppWls}{ A simple class for fitting weighted least
+            squares repeatedly with varying weights.  The initializer
+            establishes the x matrix and y vector for this problem.
+            Each invocation of method \code{fit(weights)} does a
+            least-squares fit and returns the coefficients. }
+		}
+}
+
+\keyword{datasets}

Added: pkg/wls/man/wls-package.Rd
===================================================================
--- pkg/wls/man/wls-package.Rd	                        (rev 0)
+++ pkg/wls/man/wls-package.Rd	2010-11-13 00:16:13 UTC (rev 2432)
@@ -0,0 +1,26 @@
+\name{wls-package}
+\alias{wls-package}
+\alias{wls}
+\docType{package}
+\title{
+Weighted least squares using C++, repeated with varying weights.
+}
+\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.
+
+This (nearly trivial) package is intended to demonstrate subclassing
+of the C++ class
+with reference classes that apply weighted least squares for a variety
+of purposes.  The C++ under-layer takes over the numerical fitting with
+lower overhead in time and memory.
+}
+\author{
+John Chambers <jmc at r-project.org>
+}
+\keyword{ package }
+

Added: pkg/wls/src/Makevars
===================================================================
--- pkg/wls/src/Makevars	                        (rev 0)
+++ pkg/wls/src/Makevars	2010-11-13 00:16:13 UTC (rev 2432)
@@ -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/wls/src/Makevars.win
===================================================================
--- pkg/wls/src/Makevars.win	                        (rev 0)
+++ pkg/wls/src/Makevars.win	2010-11-13 00:16:13 UTC (rev 2432)
@@ -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/wls/src/wls.cpp
===================================================================
--- pkg/wls/src/wls.cpp	                        (rev 0)
+++ pkg/wls/src/wls.cpp	2010-11-13 00:16:13 UTC (rev 2432)
@@ -0,0 +1,67 @@
+
+#include "wls.h"
+
+using namespace Rcpp ;
+
+class Wls{
+public:
+
+    Wls() {}
+
+    Wls(SEXP xr, SEXP yr) {
+	x = NumericMatrix(xr);
+	y = NumericVector(yr);
+	xw = NumericVector(x.nrow()*x.ncol());
+	yw = NumericVector(y.size());
+	wrt = NumericVector(y.size());
+    }
+
+    NumericVector fit(SEXP wR) {
+	compute_and_apply_weights(wR);
+	return do_fit();
+    }
+
+private:
+    NumericMatrix x;
+    NumericVector y, yw, wrt, xw;
+
+	
+    NumericVector do_fit() {
+	int n = x.nrow(), p = x.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 = x.nrow(), p = x.ncol();
+	wrt = sqrt(check_weights(wR));
+	yw = y * wrt;
+	xw = x * rep(wrt, p);
+    }
+
+    NumericVector check_weights(SEXP wR) {
+	//BEGIN_RCPP
+	NumericVector w(wR);
+	if(w.size() != y.size())
+	    throw std::invalid_argument("Weight vector wrong length");
+	if(as<bool>(any( is_na(w) )))
+	    throw std::domain_error("Missing values not allowed in weights");
+	if(as<bool>(any(w < -0.0)))
+	    throw std::domain_error("Negative weights found");
+	return w;
+	//END_RCPP
+    }
+
+};
+
+RCPP_MODULE(mwls) {
+
+class_<Wls>( "cppWls" )
+    .default_constructor()
+    .constructor(init_2<NumericMatrix,NumericVector>())
+    .method("fit", &Wls::fit)
+    ;
+
+}

Added: pkg/wls/src/wls.h
===================================================================
--- pkg/wls/src/wls.h	                        (rev 0)
+++ pkg/wls/src/wls.h	2010-11-13 00:16:13 UTC (rev 2432)
@@ -0,0 +1,10 @@
+#ifndef wls_H
+#define wls_H
+
+#include <RcppArmadillo.h>
+
+typedef Rcpp::NumericVector::iterator 
+	    NumericIterator;
+
+
+#endif

Added: pkg/wls/tests/.Rhistory
===================================================================
--- pkg/wls/tests/.Rhistory	                        (rev 0)
+++ pkg/wls/tests/.Rhistory	2010-11-13 00:16:13 UTC (rev 2432)
@@ -0,0 +1,286 @@
+coef
+coef
+n
+wt
+n
+ff = tryCatch(irxly$fit(wt), error = function(e)e)
+ff
+names(ff)
+ff$message
+stopifnot
+args(grepl)
+msg$message
+msg$message
+n
+msg
+mIrwls
+str(mIrwls)
+objects(mIrwls, all=TRUE)
+mIrwls$refClassGenerators
+get("refClassGenerators", mIrwls)
+prompt(mIrwls)
+options(error=recover)
+prompt(mIrwls)
+2
+selectMethod("prompt", class(mIrwls))
+objects()
+object$pointer
+class(object)
+getSlots(class(object))
+as.environment(object)$pointer
+typeof(object)
+selectMethod("$",class(object))
+object$pointer
+Q
+mIrwls$pointer
+1
+object()
+x
+as.environment(x)
+pointer
+Q
+prompt(mIrwls)
+2
+objects()
+lines
+Q
+setMethod( "prompt", "Module", function(object, filename = NULL, name = NULL, ...){
+	lines <- readLines( system.file( "prompt", "module.Rd", package = "Rcpp" ) )
+	if( is.null(name) ) name <- .Call( Module__name, .getModulePointer(object) )
+	if( is.null(filename) ) filename <- sprintf( "%s-module.Rd", name )
+	lines <- gsub( "NAME", name, lines )
+	
+	info <- functions( object )
+	f.txt <- if( length( info ) ){
+		sprintf( "functions: \\\\describe{
+%s
+		}", paste( sprintf( "        \\\\item{%s}{ ~~ description of function %s ~~ }", names(info), names(info) ), collapse = "\n" ) )
+	} else {
+		"" 
+	}
+	lines <- sub( "FUNCTIONS", f.txt, lines )
+
+        ## at this point functions() would have failed if the
+        ## pointer in object was not valid
+        pointer <- .getModulePointer(object)
+	
+	classes <- .Call( Module__classes_info, pointer )
+	c.txt <- if( length( classes ) ){
+		sprintf( "classes: \\\\describe{
+%s
+		}", paste( sprintf( "        \\\\item{%s}{ ~~ description of class %s ~~ }", names(classes), names(classes) ), collapse = "\n" ) )
+	} else {
+		"" 
+	}
+	lines <- sub( "CLASSES", c.txt, lines )
+	
+	writeLines( lines, filename )
+	invisible(NULL)
+} )
+
+prompt(mIrwls)
+0
+n
+require(Irwls)
+prompt(mIrwls)
+prompt(mIrwls, filename = "/tmp/foo.Rd")
+trace("show", sig = "Module", browser)
+mIrwls
+n
+Module__functions_arity
+Module__name
+find("Module__name")
+info
+objects()
+wheree
+where
+environment(sys.function(2))
+objects(environment(sys.function(2)))
+Q
+n
+irwls
+trace(methods:::refClassInformation, browser)
+setRefClass("myW", contains = irwls)
+n
+superClasses
+isRefSuperClass
+otherRefClasses
+c
+options(error=recover)
+setRefClass("myW", contains = irwls)
+c
+11
+objects()
+pointer
+module
+Q
+n
+methods:::refClassInformation
+insertSource(source="/Users/jmc/R_Devel/source_devel/src/library/methods/R/refClass.R", package = "methods")
+options(error=recover)
+2
+2
+objects()
+class(x)
+.Method
+objects(x)
+Q
+0
+n
+require(Irwls)
+mIrwls
+objects(mIrwls)
+mIrwls$moduleName
+options(error=recover)
+mIrwls$moduleName
+0
+get("moduleName", envir = mIrwls)
+mm = Module("mIrwls"), asNamespace("Irwls"))
+mm = Module("mIrwls")
+mm
+objects(as.environment(mm))
+trace(Module, browser)
+mm = Module("mIrwls")
+n
+mustStart
+xp
+xp
+.badModulePointer
+Q
+args(Module)
+mm = Module("mIrwls", mustStart = TRUE)
+n
+xp
+symbol
+Q
+mm = Module("mIrwls", mustStart = TRUE, package = "Irwls")
+0
+args(Module)
+mm = Module("mIrwls", mustStart = TRUE, PACKAGE = "Irwls")
+n
+symbol
+c
+3
+objects()
+Q
+n
+require(Irwls)
+mIrwls
+objects(mIrwls)
+mIrwls <- Module("mIrwls", PACKAGE="Irwls")
+objects(mIrwls)
+mIrwls <- Module("mIrwls", PACKAGE="Irwls", mustStart = TRUE)
+objects(mIrwls)
+get("refClassGenerators", mIrwls)
+objects(asNamespace("Irwls"), all=TRUE)
+Rcpp:::.getModulePointer
+mIrwls$cppIrwls
+n
+require(Irwls)
+trace(Rcpp:::.getModulePointer, browser)
+ mIrwls$cppIrwls
+n
+pointer
+trace(Module, browser)
+n
+where
+xp
+symbol
+xp
+classes
+where
+pointer
+n
+require(Irwls)
+mIrwls$cppIrwls
+setRefClass("myw", contains = mIrwls$cppIrwls)
+extends("myw")
+isRefClass("Rcpp_cppIrwls")
+isReferenceClass("Rcpp_cppIrwls")
+is(getClass("Rcpp_cppIrwls"), "refClassRepresentation")
+trace(methods:::refClassInformation, browser)
+setRefClass("myw", contains = mIrwls$cppIrwls)
+n
+superClasses
+n
+cc = list(a=1, b=2)
+cc[["d"]] = 3
+dput(cc)
+Q
+n
+require(Irwls)
+myw <- setRefClass("myw", contains = mIrwls$cppIrwls)
+mi <- myw$new(xx, y)
+mi
+coef <- mi$fit(rep(1,0))
+coef <- mi$fit(rep(1,10))
+coef
+getClasses(1)
+as.character(mIrwls$cppIrwls)
+getClass(mIrwls$cppIrwls)
+n
+require(Irwls)
+getClasses(1)
+getClasses(2)
+search()
+trace(assignClassDef, browser)
+mIrwls$cppIrwls
+where
+Q
+setClass("mm", contains = "environment", representation(flag = "character")
+)
+untrace(assignClassDef)
+vv = new("mm
+vv = new("mm")
+vv$a = 1
+vv
+vv[["a"]] = 1
+vv
+showMethods("[[<-")
+showMethods("$<-")
+selectMethod("$<-", "envRefClass")
+getGeneric("[[<-")
+t1
+t1
+tl
+tl$x
+tl
+showMethods("$")
+selectMethods("$", "ANY")
+selectMethod("$", "ANY")
+getClass("myEnv")
+showMethods("[[<-")
+n
+m$y <- 2
+m
+showMethods("$<-")
+selectMethod("$<-", "myEnv")
+n
+m
+as.list(tl)
+unclass(tl)
+tl$z
+tl
+tl <- new("mylist")
+tl[["z"]] <- 1
+tl
+tl$z
+tl at .Data
+unclass(tl)
+tl
+tl[["z"]] <- 1
+tl
+names(tl)
+tl[["z"]]
+tl = new("mylist"); tl$z <- 1
+tl
+tl = new("mylist"); tl[["z"]] <-1
+tl
+print(tl)
+names(tl)
+getClass("mylist")
+tl
+tl$z
+tl
+tl$z
+n

Added: pkg/wls/tests/trivial.R
===================================================================
--- pkg/wls/tests/trivial.R	                        (rev 0)
+++ pkg/wls/tests/trivial.R	2010-11-13 00:16:13 UTC (rev 2432)
@@ -0,0 +1,23 @@
+require(wls)
+irwls <- mwls$cppWls
+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)))
+wt[1] <- -1
+msg <- tryCatch(irxly$fit(wt), error = function(e)e)
+stopifnot(is(msg,"error"), grepl("negative", msg$message, ignore.case = TRUE))
+wt <- wt[-1]
+msg <- tryCatch(irxly$fit(wt), error = function(e)e)
+stopifnot(is(msg,"error"), grepl("length", msg$message, ignore.case = TRUE))
+wt <- c(NA, wt)
+msg <- tryCatch(irxly$fit(wt), error = function(e)e)
+stopifnot(is(msg,"error"), grepl("missing", msg$message, ignore.case = TRUE))



More information about the Rcpp-commits mailing list