[Robast-commits] r1133 - branches/robast-1.2/pkg/ROptEst/R

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

Author: ruckdeschel
Date: 2018-08-12 17:54:52 +0200 (Sun, 12 Aug 2018)
New Revision: 1133

Modified:
   branches/robast-1.2/pkg/ROptEst/R/CheckMakeContIC.R
   branches/robast-1.2/pkg/ROptEst/R/getInfV.R
Log:
[ROptEst] branch 1.2
bugfixes in the new, faster CheckIC /MakeIC method (in particular the Curve in make IC was completely wrong!)


Modified: branches/robast-1.2/pkg/ROptEst/R/CheckMakeContIC.R
===================================================================
--- branches/robast-1.2/pkg/ROptEst/R/CheckMakeContIC.R	2018-08-12 15:52:52 UTC (rev 1132)
+++ branches/robast-1.2/pkg/ROptEst/R/CheckMakeContIC.R	2018-08-12 15:54:52 UTC (rev 1133)
@@ -26,7 +26,8 @@
         A <- stand(IC);  a <- cent(IC)
         G1 <- res$G1;  G2 <- res$G2;  G3 <- res$G3
         Delta1 <- A%*%G2- a*G1
-        Delta2 <- A%*%G3 - a%*%t(G2) - trafo(L2Fam at param)
+        Delta2 <- A%*%G3 - a%*%t(G2)
+        Delta2 <- Delta2 - trafo(L2Fam)
 
         if(out)
             cat("precision of centering:\t", Delta1, "\n")
@@ -52,6 +53,7 @@
         if( dimension(Domain(IC at Curve[[1]])) != dimension(img(D1)))
             stop("dimension of 'Domain' of 'Curve' != dimension of 'img' of 'distribution' of 'L2Fam'")
 
+        dims <- nrow(trafo(L2Fam))
         if(dimension(IC at Curve) != dims)
            stop("Dimension of IC and parameter must be equal")
 
@@ -71,34 +73,32 @@
                               L2Fam = "L2ParamFamily"))(IC,L2Fam))
 
         G1 <- res$G1;  G2 <- res$G2;  G3 <- res$G3
-        trafo <- trafo(L2Fam at param)
-        nrvalues <- nrow(trafo)
-        dims <- ncol(trafo)
+        trafO <- trafo(L2Fam at param)
+        nrvalues <- nrow(trafO)
+        dims <- ncol(trafO)
 
-        cent0 <- G2/G1
-        stand1 <- trafo%*%distr::solve(G3-cent0%*%t(G2))
-        cent1 <- stand1%*%cent0
-
-        L2deriv <- as(diag(dims) %*% L2Fam at L2deriv, "EuclRandVariable")
+        cent0 <- c(G2/G1)
+        stand1 <- trafO%*%distr::solve(G3-cent0%*%t(G2))
+        cent1 <- c(stand1%*%cent0)
+#        print(list(stand1,stand(IC),cent1,cent(IC)))
+        L2.f <- as(diag(nrvalues) %*% L2Fam at L2deriv , "EuclRandVariable")
         D1 <- L2Fam at distribution
 
-        IC1.0 <- stand1%*%L2deriv
-        IC1.1 <- IC1.0 -cent1
-        IC1.f <- function(x) evalRandVar(IC1.1,x)
+        IC1.f <- function(x){ indS <- liesInSupport(D1,x,checkFin=TRUE)
+                              Lx <- sapply(x, function(y) evalRandVar(L2.f,y))
+                              indS* (stand1%*%Lx-cent1) * weight(IC at weight)(Lx)}
 
         IC1.l <- vector("list",nrvalues)
         for(i in 1:nrvalues){
             IC1.l[[i]] <- function(x){}
-            body(IC.l[[i]]) <- substitute({indS <- liesInSupport(D0,x,checkFin=TRUE)
-                                           indS*((IC1.s(x))[i])
-                                           }, list(IC1.s=IC1.f, D0=D1, i=i))
+            body(IC1.l[[i]]) <- substitute( c((IC1.s(x))[i,]), list(IC1.s=IC1.f, i=i))
         }
-        IC1.c <- EuclRandVariable(Map = IC1.l, Domain = IC at Curve[[1]],
+        IC1.c <- EuclRandVariable(Map = IC1.l, Domain = Domain(IC at Curve[[1]]),
                                 Range = Reals())
 
         cIC1 <- new("ContIC")
-        cIC1 at name <- name
-        cIC1 at Curve <- IC1.c
+        cIC1 at name <- IC at name
+        cIC1 at Curve <- EuclRandVarList(IC1.c)
         cIC1 at Risks <- IC at Risks
         cIC1 at Infos <- IC at Infos
         cIC1 at CallL2Fam <- L2Fam at fam.call
@@ -131,6 +131,7 @@
 
         z.comp <- rep(TRUE,dims)
         A.comp <- matrix(TRUE, dims, dims)
+#        print(list(z.comp,A.comp))
         # otherwise if trafo == unitMatrix may use symmetry info
         if(.isUnitMatrix(trafo)){
             comp <- .getComp(L2deriv, L2Fam at distrSymm, L2Fam at L2derivSymm, L2Fam at L2derivDistrSymm)

Modified: branches/robast-1.2/pkg/ROptEst/R/getInfV.R
===================================================================
--- branches/robast-1.2/pkg/ROptEst/R/getInfV.R	2018-08-12 15:52:52 UTC (rev 1132)
+++ branches/robast-1.2/pkg/ROptEst/R/getInfV.R	2018-08-12 15:54:52 UTC (rev 1133)
@@ -51,7 +51,6 @@
         integrandV <- function(x, L2.i, L2.j, i, j){
             return((L2.i(x) - cent0[i])*(L2.j(x) - cent0[j])*w.fct(x = x))
         }
-
         nrvalues <- length(L2deriv)
         erg <- matrix(0, ncol = nrvalues, nrow = nrvalues)
         for(i in 1:nrvalues)