[Robast-commits] r1132 - branches/robast-1.2/pkg/RobAStBase/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sun Aug 12 17:52:53 CEST 2018
Author: ruckdeschel
Date: 2018-08-12 17:52:52 +0200 (Sun, 12 Aug 2018)
New Revision: 1132
Modified:
branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R
branches/robast-1.2/pkg/RobAStBase/R/generateICfct.R
branches/robast-1.2/pkg/RobAStBase/R/getRiskIC.R
branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R
Log:
[RobAStBase] 1.branch 2
+ yet another time bug fixes : L2Fam instead of L2Fam0
+ better vectorized code gemerated by generateICfct.R
+ getRisk IC caused quite a bit of delay -- now avoids this useApply issue
Modified: branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R
===================================================================
--- branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R 2018-08-12 08:54:12 UTC (rev 1131)
+++ branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R 2018-08-12 15:52:52 UTC (rev 1132)
@@ -100,7 +100,8 @@
cent <- res$E.IC
stand <- trafo %*% distr::solve(res$E.IC.L, generalized = TRUE)
- Y <- as(stand %*% (IC1 - cent), "EuclRandVariable")
+ IC1.0 <- IC1 - cent
+ Y <- as(stand %*% IC1.0, "EuclRandVariable")
modifyIC <- IC at modifyIC
@@ -123,7 +124,7 @@
## make some L2function a pIC at a model
setMethod("makeIC", signature(IC = "IC", L2Fam = "missing"),
function(IC, ...){
- L2Fam0 <- eval(IC at CallL2Fam)
+ L2Fam <- eval(IC at CallL2Fam)
getMethod("makeIC", signature(IC = "IC", L2Fam = "L2ParamFamily"))(
IC = IC, L2Fam = L2Fam, ...)
})
Modified: branches/robast-1.2/pkg/RobAStBase/R/generateICfct.R
===================================================================
--- branches/robast-1.2/pkg/RobAStBase/R/generateICfct.R 2018-08-12 08:54:12 UTC (rev 1131)
+++ branches/robast-1.2/pkg/RobAStBase/R/generateICfct.R 2018-08-12 15:52:52 UTC (rev 1132)
@@ -3,7 +3,7 @@
setMethod("generateIC.fct", signature(neighbor = "UncondNeighborhood", L2Fam = "L2ParamFamily"),
function(neighbor, L2Fam, res){
A <- as.matrix(res$A)
- a <- if(is(neighbor,"TotalVarNeighborhood")) 0 else res$a
+ a <- if(is(neighbor,"TotalVarNeighborhood")) 0 else res$a
b <- res$b
d <- if(!is.null(res$d)) res$d else 0
w <- weight(res$w)
@@ -20,16 +20,15 @@
if(dims==1L){
body(ICfct[[1]]) <- substitute(
{ Lx <- L(x); wx <- w(Lx)
- print(str(a)); print(str(A));print(str(Lx)); print(str(w(Lx)))
Yx <- A %*% Lx - a
- ifelse(.eq(Yx),zi*d*b,as.numeric(Yx*w(Lx))) },
+ ifelse(1-.eq(Yx),as.numeric(Yx*w(Lx)),zi*d*b) },
list(L = L.fct, w = w, b = b, d = d, A = A, a = a,
zi = sign(trafo(L2Fam at param)), .eq = .eq))
}else{
body(ICfct[[1]]) <- substitute(
{ Lx <- L(x); wx <- w(Lx)
Yx <- A %*% Lx - a
- ifelse(.eq(Yx), NA, as.numeric(Yx*w(Lx))) },
+ ifelse(1-.eq(Yx), as.numeric(Yx*w(Lx)), NA) },
list(L = L.fct, w = w, b = b, d = d, A = A, a = a,
.eq = .eq))
}
@@ -44,9 +43,9 @@
if(!is.null(res$d))
for(i in 1:nrvalues){
ICfct[[i]] <- function(x){}
- body(ICfct[[i]]) <- substitute({Lx <- L(x);wx <- w(Lx)
- Yix <- Ai %*% Lx - ai
- ifelse(.eq(Yix), di, as.numeric(Yix*wx))
+ body(ICfct[[i]]) <- substitute({Lx <- L(x)
+ Yix <- Ai %*% Lx - ai ; # print(dim(Yix)); print(head(Yix[,1:10]));
+ as.numeric(Yix*w(Lx) + .eq(Yix)*di)
},
list(L = L.fct, Ai = A[i,,drop=FALSE], ai = a[i], w = w,
di = d[i]))#, .eq = .eq))
@@ -54,9 +53,9 @@
else
for(i in 1:nrvalues){
ICfct[[i]] <- function(x){}
- body(ICfct[[i]]) <- substitute({Lx <- L(x);wx <- w(Lx)
+ body(ICfct[[i]]) <- substitute({Lx <- L(x)
Yix <- Ai %*% Lx - ai
- as.numeric(Yix*wx) },
+ as.numeric(Yix*w(Lx)) },
list(L = L.fct, Ai = A[i,,drop=FALSE], ai = a[i], w = w))
}
}
Modified: branches/robast-1.2/pkg/RobAStBase/R/getRiskIC.R
===================================================================
--- branches/robast-1.2/pkg/RobAStBase/R/getRiskIC.R 2018-08-12 08:54:12 UTC (rev 1131)
+++ branches/robast-1.2/pkg/RobAStBase/R/getRiskIC.R 2018-08-12 15:52:52 UTC (rev 1132)
@@ -30,15 +30,33 @@
if(dimension(Domain(IC at Curve[[1]])) != dimension(img(L2Fam at distribution)))
stop("dimension of 'Domain' of 'Curve' != dimension of 'img' of 'distribution' of 'L2Fam'")
+ dotsI <- .filterEargs(list(...))
+ if(!is.null(dotsI$useApply)) dotsI$useApply <- FALSE
+
if(missing(withCheck)) withCheck <- TRUE
IC1 <- as(diag(dimension(IC at Curve)) %*% IC at Curve, "EuclRandVariable")
- bias <- E(L2Fam, IC1, ...)
- Cov <- E(L2Fam, IC1 %*% t(IC1), ...)
+ Distr <- L2Fam at distribution
+ nrvalues <- nrow(trafo(L2Fam))
- if(withCheck) .checkICWithWarning(IC, L2Fam, tol, ...)
+ cent <- numeric(nrvalues)
+ for(i in 1:nrvalues){
+ cent[i] <- do.call(E,c(list(object = Distr, fun = IC1 at Map[[i]]), dotsI))
+ }
- return(list(asCov = list(distribution = .getDistr(L2Fam), value = Cov - bias %*% t(bias))))
+ Cova <- matrix(0, ncol = nrvalues, nrow = nrvalues)
+
+ for(i in 1:nrvalues){
+ for(j in i:nrvalues){
+ Cova[i,j] <- do.call(E,c(list(object = Distr,
+ fun = function(x){
+ return((IC1 at Map[[i]](x)-cent[i])*(IC1 at Map[[j]](x)-cent[j]))}),
+ dotsI))
+ }
+ }
+ Cova[col(Cova) < row(Cova)] <- t(Cova)[col(Cova) < row(Cova)]
+ # if(withCheck) .checkICWithWarning(IC, L2Fam, tol, ...)
+ return(list(asCov = list(distribution = .getDistr(L2Fam), value = Cova)))
})
###############################################################################
Modified: branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R
===================================================================
--- branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R 2018-08-12 08:54:12 UTC (rev 1131)
+++ branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R 2018-08-12 15:52:52 UTC (rev 1132)
@@ -152,18 +152,17 @@
pICList <- if(withPICList) vector("list", steps) else NULL
ICList <- if(withICList) vector("list", steps) else NULL
- cvar.fct <- function(L2, IC, dim, dimn =NULL){}
- body(cvar.fct) <- substitute({
- EcallArgs <- c(list(L2, IC %*% t(IC)), E.argList0)
- Eres <- do.call(E,EcallArgs)
+ cvar.fct <- function(L2, IC, dim, dimn =NULL){
+ Eres <- matrix(NA,dim,dim)
+ if(!is.null(dimn)) dimnames(Eres) <- dimn
+ L2M <- L2 at Curve[[1]]@Map
+ for(i in 1: dim)
+ for(j in i: dim)
+ Eres[i,j] <- E(L2 at distribution,
+ fun = function(x) L2M[[i]](x)*L2M[[j]](x),
+ useApply = FALSE)
+ return(res)}
- if(is.null(dimn)){
- return(matrix(Eres,dim,dim))
- }else{
- return(matrix(Eres,dim,dim, dimnames = dimn))
- }
- }, list(E.argList0 = E.argList))
-
##-t-## updStp <- 0
### update - function
updateStep <- function(u.theta, theta, IC, L2Fam, Param,
@@ -483,8 +482,8 @@
getRiskICasVarArgs <- c(list(IC, risk = asCov(), withCheck = FALSE),E.argList)
riskAsVar <- do.call(getRiskIC, getRiskICasVarArgs)
asVar <- riskAsVar$asCov$value
- }
##-t-## })
+ }
##-t-## sytm <- .addTime(sytm,syt,"getRiskIC-Var")
}else asVar <- var0
More information about the Robast-commits
mailing list