[Analogue-commits] r126 - in pkg: R inst man

[noreply at r-forge.r-project.org]

Author: gsimpson
Date: 2009-05-28 00:33:50 +0200 (Thu, 28 May 2009)
New Revision: 126

Modified:
   pkg/R/predict.wa.R
   pkg/inst/ChangeLog
   pkg/man/analogue-internal.Rd
Log:
predict.wa now works for tol DW WA models if no CV is used

Modified: pkg/R/predict.wa.R
===================================================================
--- pkg/R/predict.wa.R	2009-05-05 21:13:46 UTC (rev 125)
+++ pkg/R/predict.wa.R	2009-05-27 22:33:50 UTC (rev 126)
@@ -1,7 +1,7 @@
 `predict.wa` <- function(object, newdata,
                          CV = c("none","LOO","bootstrap", "nfold"),
                          verbose = FALSE,
-                         n.boot = 100, nfold = 5, 
+                         n.boot = 100, nfold = 5,
                          ...) {
     if(missing(newdata))
         return(fitted(object))
@@ -29,9 +29,15 @@
         want <- names(object$wa.optima) %in%
         colnames(newdata)
         want <- names(object$wa.optima)[want]
-        pred <- colSums(t(newdata[,want]) *
-                        object$wa.optima[want]) /
-                            rowSums(newdata[,want])
+        #pred <- colSums(t(newdata[,want]) *
+        #                object$wa.optima[want]) /
+        #                    rowSums(newdata[,want])
+        if(object$tol.dw) {
+            pred <- WATpred(newdata[,want], object$wa.optima[want],
+                            object$model.tol[want])
+        } else {
+            pred <- WApred(newdata[,want], object$wa.optima[want])
+        }
         pred <- deshrink.pred(pred, coef(object))
     } else {
         ## CV wanted
@@ -125,7 +131,7 @@
                 ## n-fold sample
                 pind <- sample(ind)
                 for (k in seq_len(nfold)) {
-                    sel <- pind != k 
+                    sel <- pind != k
                     wa.optima <- w.avg(X[sel,], ENV[sel])
                     ## do the model bits
                     ones <- rep(1, length = length(wa.optima))
@@ -218,3 +224,15 @@
     class(retval) <- "predict.wa"
     retval
 }
+
+WApred <- function(X, optima) {
+    ((X %*% optima) / rowSums(X))[,1, drop = TRUE]
+}
+
+WATpred <- function(X, optima, tol) {
+    tol2 <- tol^2
+    tmp <- sweep(X, 2, optima, "*", check.margin = FALSE)
+    tmp <- rowSums(sweep(tmp, 2, tol2, "/",
+                         check.margin = FALSE))
+    tmp / rowSums(sweep(X, 2, tol2, "/", check.margin = FALSE))
+}

Modified: pkg/inst/ChangeLog
===================================================================
--- pkg/inst/ChangeLog	2009-05-05 21:13:46 UTC (rev 125)
+++ pkg/inst/ChangeLog	2009-05-27 22:33:50 UTC (rev 126)
@@ -1,5 +1,13 @@
 analogue Change Log
 
+Version 0.6-9 (Opened Wed 27 May 2009)
+
+	* predict.wa: Predictions without CV can now be made for WA models
+	fitted using tolerance DW.
+
+	* Utility functions: WApred() and WATpred() internal functions for
+	predictions using WA or WA with tolerance DW.
+
 Version 0.6-8 (Closed Mon 5 May 2009)
 
 	* residLen: new function to compute squared residual length 

Modified: pkg/man/analogue-internal.Rd
===================================================================
--- pkg/man/analogue-internal.Rd	2009-05-05 21:13:46 UTC (rev 125)
+++ pkg/man/analogue-internal.Rd	2009-05-27 22:33:50 UTC (rev 126)
@@ -15,6 +15,8 @@
 \alias{deshrink.pred}
 \alias{sppN2}
 \alias{w.tol}
+\alias{WApred}
+\alias{WATpred}
 \title{Internal analogue Functions}
 \description{
   Internal analogue functions