[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