[Robast-commits] r1181 - branches/robast-1.2/pkg/RobAStBase/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sat Mar 2 16:48:00 CET 2019
Author: ruckdeschel
Date: 2019-03-02 16:47:59 +0100 (Sat, 02 Mar 2019)
New Revision: 1181
Modified:
branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R
branches/robast-1.2/pkg/RobAStBase/R/getPIC.R
branches/robast-1.2/pkg/RobAStBase/R/internalGridHelpers.R
branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R
Log:
[RobAStBase] branch 1.2:
-checkMake IC argument passing diagnostic=diagnostic was clitched by lazy evaluation
-in .getL2Fam: we had to name parameter coordinates in order to produce sensible calls in modifyModel
-in .producePanelFirstSn we had to balance out the case where axes are logarithmic
-in kStepEstimator we used the L2diff instead of the IC when computing the asVar matrix
Modified: branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R
===================================================================
--- branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R 2019-03-02 15:42:24 UTC (rev 1180)
+++ branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R 2019-03-02 15:47:59 UTC (rev 1181)
@@ -49,21 +49,25 @@
## check centering and Fisher consistency
setMethod("checkIC", signature(IC = "IC", L2Fam = "missing"),
function(IC, out = TRUE, ..., diagnostic = FALSE){
+ diagn0stic <- diagnostic
L2Fam <- eval(IC at CallL2Fam)
getMethod("checkIC", signature(IC = "IC", L2Fam = "L2ParamFamily"))(
- IC = IC, L2Fam = L2Fam, out = out, ..., diagnostic = diagnostic)
+ IC = IC, L2Fam = L2Fam, out = out, ..., diagnostic = diagn0stic)
})
## check centering and Fisher consistency
setMethod("checkIC", signature(IC = "IC", L2Fam = "L2ParamFamily"),
function(IC, L2Fam, out = TRUE, ..., diagnostic = FALSE){
+
+ diagn0stic <- diagnostic
+
D1 <- L2Fam at distribution
if(dimension(Domain(IC at Curve[[1]])) != dimension(img(D1)))
stop("dimension of 'Domain' of 'Curve' != dimension of 'img' of 'distribution' of 'L2Fam'")
trafo <- trafo(L2Fam at param)
- res <- .preparedirectCheckMakeIC(L2Fam, IC, ..., diagnostic = diagnostic)
+ res <- .preparedirectCheckMakeIC(L2Fam, IC, ..., diagnostic = diagn0stic)
cent <- res$E.IC
attr(cent,"diagnostic") <- NULL
@@ -111,6 +115,8 @@
setMethod("makeIC", signature(IC = "IC", L2Fam = "L2ParamFamily"),
function(IC, L2Fam, ..., diagnostic = FALSE){
+ diagn0stic <- diagnostic
+
dims <- length(L2Fam at param)
if(dimension(IC at Curve) != dims)
stop("Dimension of IC and parameter must be equal")
@@ -121,7 +127,7 @@
trafo <- trafo(L2Fam at param)
- res <- .preparedirectCheckMakeIC(L2Fam, IC, ..., diagnostic = diagnostic)
+ res <- .preparedirectCheckMakeIC(L2Fam, IC, ..., diagnostic = diagn0stic)
if(diagnostic){
print(attr(res$E.IC,"diagnostic"), xname="E.IC")
@@ -165,9 +171,10 @@
## make some L2function a pIC at a model
setMethod("makeIC", signature(IC = "IC", L2Fam = "missing"),
function(IC, ..., diagnostic = FALSE){
+ diagn0stic <- diagnostic
L2Fam <- eval(IC at CallL2Fam)
getMethod("makeIC", signature(IC = "IC", L2Fam = "L2ParamFamily"))(
- IC = IC, L2Fam = L2Fam, ..., diagnostic = diagnostic)
+ IC = IC, L2Fam = L2Fam, ..., diagnostic = diagn0stic)
})
setMethod("makeIC", signature(IC = "list", L2Fam = "L2ParamFamily"),
@@ -177,6 +184,10 @@
mc0$IC <- NULL
mc0$L2Fam <- NULL
mc0$forceIC <- NULL
+ mc0$diagnostic <- NULL
+
+ diagn0stic <- diagnostic
+
if(!all(as.logical(c(lapply(IC,is.function)))))
stop("First argument must be a list of functions")
@@ -186,8 +197,9 @@
mc0$Curve <- EuclRandVarList(RealRandVariable(Map = IC.1, Domain = Reals()))
mc0$CallL2Fam <- substitute(L2Fam at fam.call)
+
IC.0 <- do.call(.IC,mc0)
- if(forceIC) IC.0 <- makeIC(IC.0, L2Fam,..., diagnostic = diagnostic)
+ if(forceIC) IC.0 <- makeIC(IC.0, L2Fam,..., diagnostic = diagn0stic)
return(IC.0)
})
@@ -201,6 +213,9 @@
mc0$IC <- NULL
mc0$L2Fam <- NULL
mc0$forceIC <- NULL
+ mc0$diagnostic <- NULL
+ diagn0stic <- diagnostic
+
IC.1 <- if(length(formals(IC))==0) function(x) IC(x) else IC
mc0$Curve <- EuclRandVarList(RealRandVariable(Map = list(IC.1),
Domain = Reals()))
@@ -209,7 +224,7 @@
IC.0 <- do.call(.IC,mc0)
# print(IC.0)
- if(forceIC) IC.0 <- makeIC(IC.0, L2Fam,...)
+ if(forceIC) IC.0 <- makeIC(IC.0, L2Fam,...,diagnostic=diagn0stic)
return(IC.0)
})
## comment 20180809: reverted changes in rev 1110
Modified: branches/robast-1.2/pkg/RobAStBase/R/getPIC.R
===================================================================
--- branches/robast-1.2/pkg/RobAStBase/R/getPIC.R 2019-03-02 15:42:24 UTC (rev 1180)
+++ branches/robast-1.2/pkg/RobAStBase/R/getPIC.R 2019-03-02 15:47:59 UTC (rev 1181)
@@ -39,9 +39,13 @@
lnx <- length(nuisance(param.0))
idx.n <- rev(rev(idx)[1:lnx])
idx.m <- idx[-idx.n]
- param.0 at nuisance <- theta[idx.m]
+ th.nuis <- theta[idx.n]
+ names(th.nuis) <- names(nuisance(param.0))
+ param.0 at nuisance <- th.nuis
}
- param.0 at main <- theta[idx.m]
+ th.main <- theta[idx.m]
+ names(th.main)<- names(main(param.0))
+ param.0 at main <- th.main
param.0 at trafo <- trafo(estimator)$mat
L2Fam <- modifyModel(L2Fam0, param.0)
return(L2Fam)
Modified: branches/robast-1.2/pkg/RobAStBase/R/internalGridHelpers.R
===================================================================
--- branches/robast-1.2/pkg/RobAStBase/R/internalGridHelpers.R 2019-03-02 15:42:24 UTC (rev 1180)
+++ branches/robast-1.2/pkg/RobAStBase/R/internalGridHelpers.R 2019-03-02 15:47:59 UTC (rev 1181)
@@ -113,7 +113,7 @@
.producePanelFirstSn <- function(panelFirst,
x.ticks, scaleX, scaleX.fct,
- y.ticks, scaleY, scaleY.fct){
+ y.ticks, scaleY, scaleY.fct, logArg){
if(is.null(scaleX.fct)) scaleX.fct <- pnorm
@@ -122,13 +122,15 @@
if(!is.null(x.ticks)){
.xticksS <- substitute({.x.ticks <- x0}, list(x0 = if(scaleX) x.ticks else scaleX.fct(x.ticks)))
}else{
+ logx <- FALSE
+ if(!is.null(logArg)) if(grepl("x",logArg)) logx <- TRUE
if(!scaleX){
- .xticksS <- substitute({
- .x.ticks <- axTicks(1, axp=par("xaxp"), usr=par("usr"))
- })
+ .xticksS <- if(logx)
+ substitute(.x.ticks <- axTicks(1, log=TRUE)) else
+ substitute(.x.ticks <- axTicks(1, axp=par("xaxp"), usr=par("usr")))
}else{
.xticksS <- substitute({
- .x.ticks <- fct(axTicks(1, axp=par("xaxp"), usr=par("usr")))
+ .x.ticks <- fct(axTicks(1, axp=par("xaxp"), usr=par("usr")))
},list(fct=scaleX.fct))
}
}
@@ -136,10 +138,12 @@
if(!is.null(y.ticks)){
.yticksS <- substitute({.y.ticks <- y0}, list(y0 = if(scaleY) y.ticks else scaleY.fct(y.ticks)))
}else{
+ logy <- FALSE
+ if(!is.null(logArg)) if(grepl("y",logArg)) logy <- TRUE
if(!scaleY){
- .yticksS <- substitute({
- .y.ticks <- axTicks(2, axp=par("yaxp"), usr=par("usr"))
- })
+ .yticksS <- if(logy)
+ substitute(.y.ticks <- axTicks(2, log=TRUE)) else
+ substitute(.y.ticks <- axTicks(2, axp=par("yaxp"), usr=par("usr")))
}else{
.yticksS <- substitute({
.y.ticks <- fct(axTicks(2, axp=par("yaxp"), usr=par("usr")))
@@ -385,7 +389,7 @@
x.ticks = x.ticks[[i]], scaleX = scaleX[i],
scaleX.fct = scaleX.fct[[i]],
y.ticks = y.ticks[[i]], scaleY = scaleY[i],
- scaleY.fct = scaleY.fct[[i]])
+ scaleY.fct = scaleY.fct[[i]], logArg[i])
}
}
Modified: branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R
===================================================================
--- branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R 2019-03-02 15:42:24 UTC (rev 1180)
+++ branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R 2019-03-02 15:47:59 UTC (rev 1181)
@@ -166,14 +166,22 @@
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
+ ICM <- as(diag(k)%*%IC, "EuclRandVariable")@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),
+ Eres[i,i] <- E(L2 at distribution,
+ fun = function(x) ICM[[i]](x)^2,
useApply = FALSE)
+ if(dim>1){
+ for(i in 1: (dim-1)){
+ for(j in (i+1): dim)
+ Eres[j,i] <- Eres[i,j] <- E(L2 at distribution,
+ fun = function(x) ICM[[i]](x)*ICM[[j]](x),
+ useApply = FALSE)
+ }
+ }
return(Eres)}
+
updStp <- 0
### update - function
updateStep <- function(u.theta, theta, IC, L2Fam, Param,
@@ -276,6 +284,9 @@
correct <- rowMeans(t(t(.ensureDim2(evalRandVar(IC.c, x0)))*indS), na.rm = na.rm)
sytm <<- .addTime(sytm,paste("Dtau=Unit:correct <- rowMeans-",updStp))
iM <- is.matrix(theta)
+# print(sclname)
+# print(names(theta))
+# print(str(theta))
names(correct) <- if(iM) rownames(theta) else names(theta)
if(logtrf){
scl <- if(iM) theta[sclname,1] else theta[sclname]
@@ -377,6 +388,8 @@
withEvalAsVar.0 = (i==steps))
# print(upd$u.theta); print(upd$theta)
uksteps[,i] <- u.theta <- upd$u.theta
+# print(str(upd$theta))
+# print(nrow(ksteps))
ksteps[,i] <- theta <- upd$theta
if(withICList)
ICList[[i]] <- .fixInLiesInSupport(
More information about the Robast-commits
mailing list