[Robast-commits] r318 - in branches/robast-0.7/pkg: ROptEst/R RobAStBase/R

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

Author: stamats
Date: 2009-07-02 14:30:09 +0200 (Thu, 02 Jul 2009)
New Revision: 318

Modified:
   branches/robast-0.7/pkg/ROptEst/R/getInfRobIC_asBias.R
   branches/robast-0.7/pkg/ROptEst/R/optIC.R
   branches/robast-0.7/pkg/RobAStBase/R/generateICfct.R
Log:
lower case and Hampel now seem to work with trafo

Modified: branches/robast-0.7/pkg/ROptEst/R/getInfRobIC_asBias.R
===================================================================
--- branches/robast-0.7/pkg/ROptEst/R/getInfRobIC_asBias.R	2009-07-01 04:30:00 UTC (rev 317)
+++ branches/robast-0.7/pkg/ROptEst/R/getInfRobIC_asBias.R	2009-07-02 12:30:09 UTC (rev 318)
@@ -153,21 +153,22 @@
                                    neighbor = "ContNeighborhood", 
                                    biastype = "BiasType"),
     function(L2deriv, neighbor, biastype, normtype, Distr, 
-             z.start, A.start,  z.comp, A.comp, trafo, maxiter,  tol){
+             z.start, A.start, z.comp, A.comp, trafo, maxiter, tol){
 
+        DA.comp <- abs(trafo) %*% A.comp != 0
         eerg <- .LowerCaseMultivariate(L2deriv, neighbor, biastype,
              normtype, Distr, trafo, z.start,
-             A.start, z.comp = z.comp, A.comp = A.comp,  maxiter, tol)
+             A.start, z.comp = z.comp, A.comp = DA.comp, maxiter, tol)
         erg <- eerg$erg
 
         b <- 1/erg$value
         param <- erg$par
-        lA.comp <- sum(A.comp)
+        lA.comp <- sum(DA.comp)
         
         p <- nrow(trafo)
         k <- ncol(trafo)
         A <- matrix(0, ncol=k, nrow=p)
-        A[A.comp] <- matrix(param[1:lA.comp], ncol=k, nrow=p)
+        A[DA.comp] <- matrix(param[1:lA.comp], ncol=k, nrow=p)
         z <- numeric(k)
         z[z.comp] <- param[(lA.comp+1):length(param)]
         a <- as.vector(A %*% z)

Modified: branches/robast-0.7/pkg/ROptEst/R/optIC.R
===================================================================
--- branches/robast-0.7/pkg/ROptEst/R/optIC.R	2009-07-01 04:30:00 UTC (rev 317)
+++ branches/robast-0.7/pkg/ROptEst/R/optIC.R	2009-07-02 12:30:09 UTC (rev 318)
@@ -55,8 +55,8 @@
                 res <- c(res, modifyIC = getModifyIC(L2FamIC = model at center, 
                                                      neighbor = model at neighbor, 
                                                      risk = risk))
-                    return(generateIC(model at neighbor, model at center, res))
-                }else{
+                return(generateIC(model at neighbor, model at center, res))
+            }else{
                 stop("not yet implemented")
             }
         }

Modified: branches/robast-0.7/pkg/RobAStBase/R/generateICfct.R
===================================================================
--- branches/robast-0.7/pkg/RobAStBase/R/generateICfct.R	2009-07-01 04:30:00 UTC (rev 317)
+++ branches/robast-0.7/pkg/RobAStBase/R/generateICfct.R	2009-07-02 12:30:09 UTC (rev 318)
@@ -16,11 +16,19 @@
         if(nrvalues == 1){
             if(!is.null(d)){
                 ICfct[[1]] <- function(x){}
-                body(ICfct[[1]]) <- substitute(
-                                        { ind <- 1-.eq(Y(x))
-                                          Y(x)*w(L(x)) + zi*(1-ind)*d*b },
-                                        list(Y = Y at Map[[1]], L = L.fct, w = w, b = b, d = d,
-                                             zi = sign(trafo(L2Fam at param)), .eq = .eq))
+                if(all(dim(trafo(L2Fam at param)) == c(1, 1))){
+                    body(ICfct[[1]]) <- substitute(
+                                            { ind <- 1-.eq(Y(x))
+                                              Y(x)*w(L(x)) + zi*(1-ind)*d*b },
+                                            list(Y = Y at Map[[1]], L = L.fct, w = w, b = b, d = d,
+                                                zi = sign(trafo(L2Fam at param)), .eq = .eq))
+                }else{
+                    body(ICfct[[1]]) <- substitute(
+                                            { ind <- 1-.eq(Y(x))
+                                              ifelse(ind, Y(x)*w(L(x)), NA) },
+                                            list(Y = Y at Map[[1]], L = L.fct, w = w, b = b, d = d, 
+                                                 .eq = .eq))
+                }
             }else{
                 ICfct[[1]] <- function(x){}
                 body(ICfct[[1]]) <- substitute({ Y(x)*w(L(x)) },