[Robast-commits] r1128 - in branches/robast-1.2/pkg/RobAStBase: . R inst man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sun Aug 12 02:07:24 CEST 2018
Author: ruckdeschel
Date: 2018-08-12 02:07:24 +0200 (Sun, 12 Aug 2018)
New Revision: 1128
Added:
branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R
Modified:
branches/robast-1.2/pkg/RobAStBase/NAMESPACE
branches/robast-1.2/pkg/RobAStBase/R/IC.R
branches/robast-1.2/pkg/RobAStBase/R/getBiasIC.R
branches/robast-1.2/pkg/RobAStBase/R/getRiskIC.R
branches/robast-1.2/pkg/RobAStBase/R/getboundedIC.R
branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R
branches/robast-1.2/pkg/RobAStBase/R/move2bckRefParam.R
branches/robast-1.2/pkg/RobAStBase/R/oneStepEstimator.R
branches/robast-1.2/pkg/RobAStBase/R/optIC.R
branches/robast-1.2/pkg/RobAStBase/inst/NEWS
branches/robast-1.2/pkg/RobAStBase/man/ContIC-class.Rd
branches/robast-1.2/pkg/RobAStBase/man/ContIC.Rd
branches/robast-1.2/pkg/RobAStBase/man/HampIC-class.Rd
branches/robast-1.2/pkg/RobAStBase/man/IC-class.Rd
branches/robast-1.2/pkg/RobAStBase/man/IC.Rd
branches/robast-1.2/pkg/RobAStBase/man/TotalVarIC-class.Rd
branches/robast-1.2/pkg/RobAStBase/man/TotalVarIC.Rd
branches/robast-1.2/pkg/RobAStBase/man/checkIC.Rd
branches/robast-1.2/pkg/RobAStBase/man/getBiasIC.Rd
branches/robast-1.2/pkg/RobAStBase/man/getBoundedIC.Rd
branches/robast-1.2/pkg/RobAStBase/man/getRiskIC.Rd
branches/robast-1.2/pkg/RobAStBase/man/internals.Rd
branches/robast-1.2/pkg/RobAStBase/man/kStepEstimator.Rd
branches/robast-1.2/pkg/RobAStBase/man/makeIC-methods.Rd
branches/robast-1.2/pkg/RobAStBase/man/oneStepEstimator.Rd
branches/robast-1.2/pkg/RobAStBase/man/optIC.Rd
Log:
[RobAStBase] branch 1.2
+ particular checkIC methods are now documented in documentation
object checkIC (and no longer with class IC); there argument out
is documented
+ checkIC and makeIC now both use helper function .preparedirectCheckMakeIC
which allows for extra arguments for E() and integrates coordinate wise with
useApply = FALSE to gain speed (code has moved from file IC.R to file CheckMakeIC.R)
+ several methods (getRiskIC, getBiasIC, getBoundedIC, makeIC, checkIC, modifyIC)
gain argument "..." to pass on arguments to E()
+ new internal constant ..IntegrateArgs which contains the names of all arguments
used for integration, i.e., currently, c("lowerTruncQuantile", "upperTruncQuantile",
"IQR.fac", "subdivisions", "rel.tol", "abs.tol", "stop.on.error", "order", "useApply")
+ getboundedIC now uses coordinate-wise integration with useApply = FALSE and
only computing the upper half of E LL'w
Modified: branches/robast-1.2/pkg/RobAStBase/NAMESPACE
===================================================================
--- branches/robast-1.2/pkg/RobAStBase/NAMESPACE 2018-08-11 14:59:35 UTC (rev 1127)
+++ branches/robast-1.2/pkg/RobAStBase/NAMESPACE 2018-08-12 00:07:24 UTC (rev 1128)
@@ -89,4 +89,4 @@
export(".rescalefct",".plotRescaledAxis",".makedotsP",".makedotsLowLevel",".SelectOrderData")
export(".merge.lists")
export("InfoPlot", "ComparePlot", "PlotIC")
-export(".fixInLiesInSupport")
\ No newline at end of file
+export(".fixInLiesInSupport", "..IntegrateArgs")
\ No newline at end of file
Added: branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R
===================================================================
--- branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R (rev 0)
+++ branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R 2018-08-12 00:07:24 UTC (rev 1128)
@@ -0,0 +1,178 @@
+## new helper function for make and check IC to speed up things
+
+.preparedirectCheckMakeIC <- function(L2Fam, IC, ...){
+
+ dims <- length(L2Fam at param)
+ trafo <- trafo(L2Fam at param)
+ nrvalues <- nrow(trafo)
+ Distr <- L2Fam at distribution
+
+ dots <- list(...)
+ dotsI <- list()
+ for(item in ..IntegrateArgs) dotsI[[item]] <- dots[[item]]
+ if(!is.null(dotsI$useApply)) dotsI$useApply <- FALSE
+
+
+ IC.v <- as(diag(nrvalues) %*% IC at Curve, "EuclRandVariable")
+ L2deriv <- as(diag(dims) %*% L2Fam at L2deriv, "EuclRandVariable")
+
+ res <- numeric(nrvalues)
+ for(i in 1:nrvalues){
+ Eargs <- c(list(object = Distr, fun = IC.v at Map[[i]]), dotsI)
+ res[i] <- do.call(E, Eargs)
+ }
+
+ integrandA <- function(x, IC.i, L2.j){
+ return(IC.i(x)*L2.j(x))
+ }
+
+ erg <- matrix(0, ncol = nrvalues, nrow = nrvalues)
+
+ for(i in 1:nrvalues)
+ for(j in 1:nrvalues){
+ Eargs <- c(list(object = Distr, fun = integrandA,
+ IC.i = IC.v at Map[[i]], L2.j = L2deriv at Map[[j]]),
+ dotsI)
+ erg[i, j] <- do.call(E, Eargs)
+ }
+
+ return(list(E.IC=res,E.IC.L=erg))
+}
+
+
+
+## check centering and Fisher consistency
+setMethod("checkIC", signature(IC = "IC", L2Fam = "missing"),
+ function(IC, out = TRUE, ...){
+ L2Fam <- eval(IC at CallL2Fam)
+ getMethod("checkIC", signature(IC = "IC", L2Fam = "L2ParamFamily"))(
+ IC = IC, L2Fam = L2Fam, out = out, ...)
+ })
+
+## check centering and Fisher consistency
+setMethod("checkIC", signature(IC = "IC", L2Fam = "L2ParamFamily"),
+ function(IC, L2Fam, out = TRUE, ...){
+ 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, ...)
+
+ cent <- res$E.IC
+ if(out)
+ cat("precision of centering:\t", cent, "\n")
+
+
+ consist <- res$E.IC.L - trafo
+
+ if(out){
+ cat("precision of Fisher consistency:\n")
+ print(consist)
+ cat("precision of Fisher consistency - relative error [%]:\n")
+ print(100*consist/trafo)
+ }
+
+ prec <- max(abs(cent), abs(consist))
+ names(prec) <- "maximum deviation"
+
+ return(prec)
+ })
+
+
+## make some L2function a pIC at a model
+setMethod("makeIC", signature(IC = "IC", L2Fam = "L2ParamFamily"),
+ function(IC, L2Fam, ...){
+
+ dims <- length(L2Fam at param)
+ if(dimension(IC at Curve) != dims)
+ stop("Dimension of IC and parameter must be equal")
+
+ 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, ...)
+
+ IC1 <- as(diag(dimension(IC at Curve)) %*% IC at Curve, "EuclRandVariable")
+
+ cent <- res$E.IC
+ stand <- trafo %*% distr::solve(res$E.IC.L, generalized = TRUE)
+
+ Y <- as(stand %*% (IC1 - cent), "EuclRandVariable")
+
+ modifyIC <- IC at modifyIC
+
+ if(!is.function(IC at modifyIC))
+ modifyIC <- function(L2Fam, IC, withMakeIC = FALSE, ...)
+ return(makeIC(IC,L2Fam, ...))
+
+ CallL2Fam <- L2Fam at fam.call
+
+ return(IC(name = name(IC),
+ Curve = EuclRandVarList(Y),
+ Risks = list(),
+ Infos=matrix(c("IC<-",
+ "generated by affine linear trafo to enforce consistency"),
+ ncol=2, dimnames=list(character(0), c("method", "message"))),
+ CallL2Fam = CallL2Fam,
+ modifyIC = modifyIC))
+ })
+
+## make some L2function a pIC at a model
+setMethod("makeIC", signature(IC = "IC", L2Fam = "missing"),
+ function(IC, ...){
+ L2Fam0 <- eval(IC at CallL2Fam)
+ getMethod("makeIC", signature(IC = "IC", L2Fam = "L2ParamFamily"))(
+ IC = IC, L2Fam = L2Fam, ...)
+ })
+
+setMethod("makeIC", signature(IC = "list", L2Fam = "L2ParamFamily"),
+ function(IC, L2Fam, forceIC = TRUE, name, Risks, Infos, modifyIC = NULL,...){
+ mc <- match.call(call = sys.call(sys.parent(1)), expand.dots = FALSE)[-1]
+ mc0 <- as.list(mc)
+ mc0$IC <- NULL
+ mc0$L2Fam <- NULL
+ mc0$forceIC <- NULL
+ if(!all(as.logical(c(lapply(IC,is.function)))))
+ stop("First argument must be a list of functions")
+
+ IC.1 <- lapply(IC, function(IC.2)
+ if(length(formals(IC.2))==0) function(x) IC.2(x) else IC.2)
+
+ 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,...)
+ return(IC.0)
+ })
+
+
+
+setMethod("makeIC", signature(IC = "function", L2Fam = "L2ParamFamily"),
+ function(IC, L2Fam, forceIC = TRUE, name, Risks, Infos, modifyIC = NULL,...){
+ mc <- match.call(call = sys.call(sys.parent(1)), expand.dots = FALSE)[-1]
+ mc0 <- as.list(mc)
+ mc0$IC <- NULL
+ mc0$L2Fam <- NULL
+ mc0$forceIC <- NULL
+ IC.1 <- if(length(formals(IC))==0) function(x) IC(x) else IC
+ mc0$Curve <- EuclRandVarList(RealRandVariable(Map = list(IC.1),
+ Domain = Reals()))
+ mc0$CallL2Fam <- substitute(L2Fam at fam.call)
+ print(mc0)
+
+ IC.0 <- do.call(.IC,mc0)
+ print(IC.0)
+ if(forceIC) IC.0 <- makeIC(IC.0, L2Fam,...)
+ return(IC.0)
+ })
+## comment 20180809: reverted changes in rev 1110
+
+..IntegrateArgs <- c("lowerTruncQuantile", "upperTruncQuantile",
+ "IQR.fac", "subdivisions", "rel.tol", "abs.tol", "stop.on.error",
+ "order", "useApply")
Modified: branches/robast-1.2/pkg/RobAStBase/R/IC.R
===================================================================
--- branches/robast-1.2/pkg/RobAStBase/R/IC.R 2018-08-11 14:59:35 UTC (rev 1127)
+++ branches/robast-1.2/pkg/RobAStBase/R/IC.R 2018-08-12 00:07:24 UTC (rev 1128)
@@ -38,6 +38,10 @@
return(IC1)
}
+# alias to generator function IC needed in functions makeIC in file CheckMakeIC.R
+.IC <- IC
+
+
## access methods
setMethod("CallL2Fam", "IC", function(object) object at CallL2Fam)
setMethod("modifyIC", "IC", function(object) object at modifyIC)
@@ -49,42 +53,8 @@
object
})
-## check centering and Fisher consistency
-setMethod("checkIC", signature(IC = "IC", L2Fam = "missing"),
- function(IC, out = TRUE, ...){
- L2Fam <- eval(IC at CallL2Fam)
- checkIC(IC, L2Fam, out = out, ...)
- })
-## check centering and Fisher consistency
-setMethod("checkIC", signature(IC = "IC", L2Fam = "L2ParamFamily"),
- function(IC, L2Fam, out = TRUE, ...){
- 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'")
+## moved checkIC and makeIC methods in file CheckMakeIC.R in rev 1128
- trafo <- trafo(L2Fam at param)
- IC1 <- as(diag(dimension(IC at Curve)) %*% IC at Curve, "EuclRandVariable")
- cent <- E(D1, IC1, ...)
- if(out)
- cat("precision of centering:\t", cent, "\n")
-
- dims <- length(L2Fam at param)
- L2deriv <- as(diag(dims) %*% L2Fam at L2deriv, "EuclRandVariable")
-
- consist <- E(D1, IC1 %*% t(L2deriv), ...) - trafo
- if(out){
- cat("precision of Fisher consistency:\n")
- print(consist)
- cat("precision of Fisher consistency - relative error [%]:\n")
- print(100*consist/trafo)
- }
-
- prec <- max(abs(cent), abs(consist))
- names(prec) <- "maximum deviation"
-
- return(prec)
- })
-
## evaluate IC
setMethod("evalIC", signature(IC = "IC", x = "numeric"),
function(IC, x){
@@ -114,110 +84,3 @@
return(evalRandVar(Curve, x)[,,1])
})
-## make some L2function a pIC at a model
-setMethod("makeIC", signature(IC = "IC", L2Fam = "missing"),
- function(IC){
- L2Fam <- eval(IC at CallL2Fam)
- makeIC(IC, L2Fam)
- })
-
-## make some L2function a pIC at a model
-setMethod("makeIC", signature(IC = "IC", L2Fam = "L2ParamFamily"),
- function(IC, L2Fam){
-
- dims <- length(L2Fam at param)
- if(dimension(IC at Curve) != dims)
- stop("Dimension of IC and parameter must be equal")
-
- 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)
- IC1 <- as(diag(dimension(IC at Curve)) %*% IC at Curve, "EuclRandVariable")
- cent <- E(D1, IC1)
- IC1 <- IC1 - cent
-
- L2deriv <- as(diag(dims) %*% L2Fam at L2deriv, "EuclRandVariable")
-
- E10 <- E(L2Fam, IC1 %*% t(L2deriv))
- E1 <- matrix(E10, dims, dims)
- stand <- trafo %*% distr::solve(E1)
- Y <- as(stand %*% IC1, "EuclRandVariable")
- #ICfct <- vector(mode = "list", length = dims)
- #ICfct[[1]] <- function(x){Y(x)}
-
-
- if(!is.function(IC at modifyIC))
- IC at modifyIC <- function(L2Fam, IC, withMakeIC = FALSE) return(makeIC(IC,L2Fam))
-# modifyIC <- ..modifnew
-# }else{
-# .modifyIC <- IC at modifyIC
-# if(!is.null(attr(IC at modifyIC,"hasMakeICin.modifyIC"))){
-# modifyIC <- .modifyIC
-# }else{
-# modifyIC <- function(L2Fam, IC){ IC. <- .modifyIC(L2Fam, IC)
-# return(makeIC(IC., L2Fam)) }
-# }
-# }
-# }
-# attr(modifyIC,"hasMakeICin.modifyIC") <- TRUE
-
- CallL2Fam <- L2Fam at fam.call
-
- return(IC(name = name(IC),
- Curve = EuclRandVarList(Y),
- Risks = list(),
- Infos=matrix(c("IC<-",
- "generated by affine linear trafo to enforce consistency"),
- ncol=2, dimnames=list(character(0), c("method", "message"))),
- CallL2Fam = CallL2Fam,
- modifyIC = IC at modifyIC))
- })
-
-
-# alias to IC needed here:
-.IC <- IC
-
-setMethod("makeIC", signature(IC = "list", L2Fam = "L2ParamFamily"),
- function(IC, L2Fam, forceIC = TRUE, name, Risks, Infos, modifyIC = NULL){
- mc <- match.call(call = sys.call(sys.parent(1)), expand.dots = FALSE)[-1]
- mc0 <- as.list(mc)
- mc0$IC <- NULL
- mc0$L2Fam <- NULL
- mc0$forceIC <- NULL
- if(!all(as.logical(c(lapply(IC,is.function)))))
- stop("First argument must be a list of functions")
-
- IC.1 <- lapply(IC, function(IC.2)
- if(length(formals(IC.2))==0) function(x) IC.2(x) else IC.2)
-
- 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)
- return(IC.0)
- })
-
-
-
-setMethod("makeIC", signature(IC = "function", L2Fam = "L2ParamFamily"),
- function(IC, L2Fam, forceIC = TRUE, name, Risks, Infos, modifyIC = NULL){
- mc <- match.call(call = sys.call(sys.parent(1)), expand.dots = FALSE)[-1]
- mc0 <- as.list(mc)
- mc0$IC <- NULL
- mc0$L2Fam <- NULL
- mc0$forceIC <- NULL
- IC.1 <- if(length(formals(IC))==0) function(x) IC(x) else IC
- mc0$Curve <- EuclRandVarList(RealRandVariable(Map = list(IC.1),
- Domain = Reals()))
- mc0$CallL2Fam <- substitute(L2Fam at fam.call)
- print(mc0)
-
- IC.0 <- do.call(.IC,mc0)
- print(IC.0)
- if(forceIC) IC.0 <- makeIC(IC.0, L2Fam)
- return(IC.0)
- })
-## comment 20180809: reverted changes in rev 1110
\ No newline at end of file
Modified: branches/robast-1.2/pkg/RobAStBase/R/getBiasIC.R
===================================================================
--- branches/robast-1.2/pkg/RobAStBase/R/getBiasIC.R 2018-08-11 14:59:35 UTC (rev 1127)
+++ branches/robast-1.2/pkg/RobAStBase/R/getBiasIC.R 2018-08-12 00:07:24 UTC (rev 1128)
@@ -5,7 +5,7 @@
neighbor = "UncondNeighborhood"),
function(IC, neighbor, L2Fam, biastype = symmetricBias(),
normtype = NormType(), tol = .Machine$double.eps^0.25,
- numbeval = 1e5, withCheck = TRUE){
+ numbeval = 1e5, withCheck = TRUE, ...){
misF <- FALSE
if(missing(L2Fam)){
@@ -24,7 +24,7 @@
Bias <- .evalBiasIC(IC = IC, neighbor = neighbor, biastype = biastype,
normtype = normtype, x = x, trafo = trafo(L2Fam at param))
- if(withCheck) if(misF) .checkICWithWarning(IC, tol=tol) else .checkICWithWarning(IC, L2Fam, tol=tol)
+ if(withCheck) if(misF) .checkICWithWarning(IC, tol=tol, ...) else .checkICWithWarning(IC, L2Fam, tol=tol, ...)
return(list(asBias = list(distribution = .getDistr(L2Fam),
neighborhood = neighbor at type, value = Bias)))
})
Modified: branches/robast-1.2/pkg/RobAStBase/R/getRiskIC.R
===================================================================
--- branches/robast-1.2/pkg/RobAStBase/R/getRiskIC.R 2018-08-11 14:59:35 UTC (rev 1127)
+++ branches/robast-1.2/pkg/RobAStBase/R/getRiskIC.R 2018-08-12 00:07:24 UTC (rev 1128)
@@ -1,8 +1,8 @@
-.checkICWithWarning <- function(IC, L2Fam, tol){
+.checkICWithWarning <- function(IC, L2Fam, tol, ...){
if(!missing(L2Fam)){
- prec <- checkIC(IC, L2Fam, out = FALSE)
+ prec <- checkIC(IC, L2Fam, out = FALSE, ...)
}else{
- prec <- checkIC(IC, out = FALSE)
+ prec <- checkIC(IC, out = FALSE, ...)
}
if(prec > tol)
warning("The maximum deviation from the exact IC properties is ", prec,
@@ -16,27 +16,27 @@
risk = "asCov",
neighbor = "missing",
L2Fam = "missing"),
- function(IC, risk, tol = .Machine$double.eps^0.25, withCheck = TRUE){
+ function(IC, risk, tol = .Machine$double.eps^0.25, withCheck = TRUE, ...){
if(missing(withCheck)) withCheck <- TRUE
return(getRiskIC(IC = IC, risk = risk, L2Fam = eval(IC at CallL2Fam),
- tol = tol, withCheck = withCheck))
+ tol = tol, withCheck = withCheck, ...))
})
setMethod("getRiskIC", signature(IC = "IC",
risk = "asCov",
neighbor = "missing",
L2Fam = "L2ParamFamily"),
- function(IC, risk, L2Fam, tol = .Machine$double.eps^0.25, withCheck = TRUE){
+ function(IC, risk, L2Fam, tol = .Machine$double.eps^0.25, withCheck = TRUE, ...){
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'")
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))
+ bias <- E(L2Fam, IC1, ...)
+ Cov <- E(L2Fam, IC1 %*% t(IC1), ...)
- if(withCheck) .checkICWithWarning(IC, L2Fam, tol)
+ if(withCheck) .checkICWithWarning(IC, L2Fam, tol, ...)
return(list(asCov = list(distribution = .getDistr(L2Fam), value = Cov - bias %*% t(bias))))
})
@@ -48,26 +48,26 @@
risk = "trAsCov",
neighbor = "missing",
L2Fam = "missing"),
- function(IC, risk, tol = .Machine$double.eps^0.25, withCheck = TRUE){
+ function(IC, risk, tol = .Machine$double.eps^0.25, withCheck = TRUE, ...){
if(missing(withCheck)) withCheck <- TRUE
return(getRiskIC(IC = IC, risk = risk, L2Fam = eval(IC at CallL2Fam),
- tol = tol, withCheck = withCheck))
+ tol = tol, withCheck = withCheck, ...))
})
setMethod("getRiskIC", signature(IC = "IC",
risk = "trAsCov",
neighbor = "missing",
L2Fam = "L2ParamFamily"),
- function(IC, risk, L2Fam, tol = .Machine$double.eps^0.25, withCheck = TRUE){
+ function(IC, risk, L2Fam, tol = .Machine$double.eps^0.25, withCheck = TRUE, ...){
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'")
if(missing(withCheck)) withCheck <- TRUE
- trCov <- getRiskIC(IC, risk = asCov(), L2Fam = L2Fam, withCheck = withCheck)$asCov
+ trCov <- getRiskIC(IC, risk = asCov(), L2Fam = L2Fam, withCheck = withCheck, ...)$asCov
trCov$value <- sum(diag(as.matrix(trCov$value)))
- if(withCheck) .checkICWithWarning(IC, L2Fam, tol)
+ if(withCheck) .checkICWithWarning(IC, L2Fam, tol, ...)
return(list(trAsCov = trCov))
})
@@ -78,7 +78,7 @@
risk = "asBias",
neighbor = "UncondNeighborhood",
L2Fam = "missing"),
- function(IC, risk, neighbor, tol = .Machine$double.eps^0.25, withCheck = TRUE){
+ function(IC, risk, neighbor, tol = .Machine$double.eps^0.25, withCheck = TRUE, ...){
if(missing(withCheck)) withCheck <- TRUE
@@ -90,11 +90,11 @@
risk = "asBias",
neighbor = "UncondNeighborhood",
L2Fam = "L2ParamFamily"),
- function(IC, risk, neighbor, L2Fam, tol = .Machine$double.eps^0.25, withCheck = TRUE){
+ function(IC, risk, neighbor, L2Fam, tol = .Machine$double.eps^0.25, withCheck = TRUE, ...){
if(missing(withCheck)) withCheck <- TRUE
getBiasIC(IC = IC, neighbor = neighbor, L2Fam = L2Fam,
biastype = biastype(risk), normtype = normtype(risk),
- tol = tol, withCheck = withCheck)
+ tol = tol, withCheck = withCheck, ...)
})
###############################################################################
## asymptotic MSE
@@ -103,18 +103,18 @@
risk = "asMSE",
neighbor = "UncondNeighborhood",
L2Fam = "missing"),
- function(IC, risk, neighbor, tol = .Machine$double.eps^0.25, withCheck = TRUE){
+ function(IC, risk, neighbor, tol = .Machine$double.eps^0.25, withCheck = TRUE, ...){
if(missing(withCheck)) withCheck <- TRUE
L2Fam <- eval(IC at CallL2Fam)
getRiskIC(IC = IC, risk = risk, neighbor = neighbor,
- L2Fam = L2Fam, tol = tol, withCheck = withCheck)
+ L2Fam = L2Fam, tol = tol, withCheck = withCheck, ...)
})
setMethod("getRiskIC", signature(IC = "IC",
risk = "asMSE",
neighbor = "UncondNeighborhood",
L2Fam = "L2ParamFamily"),
- function(IC, risk, neighbor, L2Fam, tol = .Machine$double.eps^0.25, withCheck = TRUE){
+ function(IC, risk, neighbor, L2Fam, tol = .Machine$double.eps^0.25, withCheck = TRUE, ...){
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'")
@@ -122,10 +122,10 @@
rad <- neighbor at radius
if(rad == Inf) return(Inf)
- trCov <- getRiskIC(IC = IC, risk = trAsCov(), L2Fam = L2Fam, withCheck = FALSE)
- Bias <- getRiskIC(IC = IC, risk = asBias(), neighbor = neighbor, L2Fam = L2Fam, withCheck = FALSE)
+ trCov <- getRiskIC(IC = IC, risk = trAsCov(), L2Fam = L2Fam, withCheck = FALSE, ...)
+ Bias <- getRiskIC(IC = IC, risk = asBias(), neighbor = neighbor, L2Fam = L2Fam, withCheck = FALSE, ...)
- if(withCheck) .checkICWithWarning(IC, L2Fam, tol)
+ if(withCheck) .checkICWithWarning(IC, L2Fam, tol, ...)
nghb <- paste(neighbor at type, "with radius", neighbor at radius)
return(list(asMSE = list(distribution = .getDistr(L2Fam),
Modified: branches/robast-1.2/pkg/RobAStBase/R/getboundedIC.R
===================================================================
--- branches/robast-1.2/pkg/RobAStBase/R/getboundedIC.R 2018-08-11 14:59:35 UTC (rev 1127)
+++ branches/robast-1.2/pkg/RobAStBase/R/getboundedIC.R 2018-08-12 00:07:24 UTC (rev 1128)
@@ -1,4 +1,10 @@
-getBoundedIC <- function(L2Fam, D=trafo(L2Fam at param)){
+getBoundedIC <- function(L2Fam, D=trafo(L2Fam at param),...){
+
+ dots <- list(...)
+ dotsI <- list()
+ for(item in ..IntegrateArgs) dotsI[[item]] <- dots[[item]]
+ if(!is.null(dotsI$useApply)) dotsI$useApply <- FALSE
+
FI <- FisherInfo(L2Fam)
bm <- sum(diag(distr::solve(FI)))
w <- new("BoundedWeight", clip = bm, weight = function(x){
@@ -13,7 +19,7 @@
L2deriv <- as(diag(dims) %*% L2Fam at L2deriv, "EuclRandVariable")
ICfct <- vector(mode = "list", length = dims)
- L.fct <- function(x) evalRandVar(L2deriv,x)
+ L.fct <- function(x) evalRandVar(L2deriv,as.matrix(x))[,,1]
for(i in 1:dims){
ICfct[[i]] <- function(x){}
@@ -26,10 +32,24 @@
Range = L2deriv at Range)
D1 <- L2Fam at distribution
- cent <- E(D1,L2w)
+ cent <- numeric(dims)
+ stand.0 <- matrix(0,dims,dims)
+
+ for(i in 1:dims){
+ fun <- function(x) {Lx <- L.fct(x); wx <- weight(w)(Lx); return(Lx[i,]*wx)}
+ Eargs <- c(list(object=D1, fun=fun), dotsI)
+ cent[i] <- do.call(E,Eargs)
+ }
+ for(i in 1:dims)
+ for(j in i:dims){
+ fun <- function(x) {Lx <- L.fct(x); wx <- weight(w)(Lx)
+ return((Lx[i,]-cent[i])*(Lx[j,]-cent[j])*wx)}
+ Eargs <- c(list(object=D1, fun=fun), dotsI)
+ stand.0[i,j] <- do.call(E,Eargs)
+ }
+ stand.0[row(stand.0)>col(stand.0)] <- t(stand.0)[row(stand.0)>col(stand.0)]
+
+ stand <- as.matrix(D %*% distr::solve(stand.0, generalized = TRUE))
L2w0 <- L2w - cent
-
- E1 <- matrix(E(D1, L2w0 %*% t(L2deriv-cent)), dims, dims)
- stand <- as.matrix(D %*% distr::solve(E1, generalized = TRUE))
return(as(stand %*% L2w0, "EuclRandVariable"))
- }
+}
Modified: branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R
===================================================================
--- branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R 2018-08-11 14:59:35 UTC (rev 1127)
+++ branches/robast-1.2/pkg/RobAStBase/R/kStepEstimator.R 2018-08-12 00:07:24 UTC (rev 1128)
@@ -34,6 +34,7 @@
.ensureDim2 <- function(x){
d <- dim(x)
if(length(d)==3L && d[3]==1L) dim(x) <- d[1:2]
+ if(length(d)==4L && d[2]==1L && d[4] == 1L) dim(x) <- d[c(1,3)]
x }
### no dispatch on top layer -> keep product structure of dependence
@@ -45,13 +46,16 @@
withPICList = getRobAStBaseOption("withPICList"),
na.rm = TRUE, startArgList = NULL, ...,
withLogScale = TRUE, withEvalAsVar = TRUE,
- withMakeIC = FALSE){
+ withMakeIC = FALSE, E.argList = NULL){
if(missing(IC.UpdateInKer)) IC.UpdateInKer <- NULL
## save call
es.call <- match.call()
es.call[[1]] <- as.name("kStepEstimator")
+ if(is.null(E.argList)) E.argList <- list()
+ if(is.null(E.argList$useApply)) E.argList$useApply <- FALSE
+
## get some dimensions
##-t-## syt <- system.time({
L2Fam <- eval(CallL2Fam(IC))
@@ -148,13 +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){
+ 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)
+
if(is.null(dimn)){
- return(matrix(E(L2, IC %*% t(IC)),dim,dim))
+ return(matrix(Eres,dim,dim))
}else{
- return(matrix(E(L2, IC %*% t(IC)),dim,dim, dimnames = dimn))
+ return(matrix(Eres,dim,dim, dimnames = dimn))
}
- }
+ }, list(E.argList0 = E.argList))
##-t-## updStp <- 0
### update - function
@@ -178,12 +186,14 @@
##-t-## sytm <<- .addTime(sytm,syt,paste("modifyModel-PreModif-",updStp))
# print(L2Fam)
##-t-## syt <- system.time({
- IC <- modifyIC(IC)(L2Fam, IC, withMakeIC = FALSE)
+ modifyICargs <- c(list(L2Fam, IC, withMakeIC = FALSE), E.argList)
+ IC <- do.call(modifyIC(IC),modifyICargs)
##-t-## })
##-t-## sytm <<- .addTime(sytm,syt,paste("modifyIC-PreModif-",updStp))
if(steps==1L && withMakeIC){
##-t-## syt <- system.time({
- IC <- makeIC(IC, L2Fam)
+ makeICargs <- c(list(IC, L2Fam),E.argList)
+ IC <- do.call(makeIC, makeICargs)
##-t-## })
##-t-## sytm <<- .addTime(sytm,syt,paste("modifyIC-makeIC-",updStp))
# IC at modifyIC <- oldmodifIC
@@ -216,7 +226,8 @@
warning("'IC.UpdateInKer' is not of class 'IC'; we use default instead.")
if(is.null(IC.UpdateInKer)){
##-t-## syt <- system.time({
- IC.tot2 <- getBoundedIC(L2Fam, D = projker)
+ getBoundedICargs <- c(list(L2Fam, D = projker),E.argList)
+ IC.tot2 <- do.call(getBoundedIC, getBoundedICargs)
##-t-## })
##-t-## sytm <<- .addTime(sytm,syt,paste("getBoundedIC-",updStp))
}else{
@@ -247,6 +258,7 @@
if(!IC.tot2.isnull) IC.tot <- IC.tot1 + IC.tot2
##-t-## syt <- system.time({
indS <- liesInSupport(distribution(L2Fam),x0,checkFin=TRUE)
+# print(str(evalRandVar(IC.tot, x0)))
correct <- rowMeans(t(t(.ensureDim2(evalRandVar(IC.tot, x0)))*indS), na.rm = na.rm)
##-t-## })
##-t-## sytm <<- .addTime(sytm,syt,paste("Dtau-not-Unit:correct <- rowMeans-",updStp))
@@ -327,7 +339,8 @@
##-t-## sytm <<- .addTime(sytm,syt,paste("modifyModel-PostModif-",updStp))
# print(L2Fam)
##-t-## syt <- system.time({
- IC <- modifyIC(IC)(L2Fam, IC, withMakeIC = withMakeIC)
+ modifyICargs <- c(list(L2Fam, IC, withMakeIC = withMakeIC), E.argList)
+ IC <- do.call(modifyIC(IC),modifyICargs)
##-t-## })
##-t-## sytm <<- .addTime(sytm,syt,paste("modifyIC-PostModif-",updStp))
# print(IC)
@@ -364,7 +377,10 @@
IC <- upd$IC
L2Fam <- upd$L2Fam
##-t-## syt <- system.time({
- if((i==steps)&&withMakeIC) IC <- makeIC(IC,L2Fam)
+ if((i==steps)&&withMakeIC){
+ makeICargs <- c(list(IC, L2Fam),E.argList)
+ IC <- do.call(makeIC, makeICargs)
+ }
##-t-## })
##-t-## sytm <- .addTime(sytm,syt,paste("makeIC-",i))
# IC at modifyIC <- modif.old
@@ -412,7 +428,10 @@
Infos <- rbind(Infos, c("kStepEstimator",
"computation of IC, trafo, asvar and asbias via useLast = TRUE"))
##-t-## syt <- system.time({
- if(withMakeIC) IC <- makeIC(IC, L2Fam)
+ if(withMakeIC){
+ makeICargs <- c(list(IC, L2Fam),E.argList)
+ IC <- do.call(makeIC, makeICargs)
+ }
##-t-## })
##-t-## sytm <- .addTime(sytm,syt,"makeIC-useLast")
}else{
@@ -456,14 +475,15 @@
## some risks
# print(list(u.theta=u.theta,theta=theta,u.var=u.var,var=var0))
if(var.to.be.c){
- if("asCov" %in% names(Risks(IC)))
- if(is.matrix(Risks(IC)$asCov) || length(Risks(IC)$asCov) == 1)
- asVar <- Risks(IC)$asCov
- else
- asVar <- Risks(IC)$asCov$value
- else
+ if("asCov" %in% names(Risks(IC))){
+ asVar <- if(is.matrix(Risks(IC)$asCov) || length(Risks(IC)$asCov) == 1)
+ Risks(IC)$asCov else Risks(IC)$asCov$value
+ }else{
##-t-## syt <- system.time({
- asVar <- getRiskIC(IC, risk = asCov(), withCheck = FALSE)$asCov$value
+ 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")
Modified: branches/robast-1.2/pkg/RobAStBase/R/move2bckRefParam.R
===================================================================
--- branches/robast-1.2/pkg/RobAStBase/R/move2bckRefParam.R 2018-08-11 14:59:35 UTC (rev 1127)
+++ branches/robast-1.2/pkg/RobAStBase/R/move2bckRefParam.R 2018-08-12 00:07:24 UTC (rev 1128)
@@ -109,6 +109,6 @@
setMethod("moveICBackFromRefParam", signature(IC = "HampIC",
L2Fam = "L2ParamFamily"), function(IC, L2Fam, ...){
IC <- moveICBackFromRefParam(as(IC,"IC"), L2Fam,...)
- IC at modifyIC(L2Fam, IC, withMakeIC = FALSE)
+ IC at modifyIC(L2Fam, IC, withMakeIC = FALSE, ...)
return(IC)})
Modified: branches/robast-1.2/pkg/RobAStBase/R/oneStepEstimator.R
===================================================================
--- branches/robast-1.2/pkg/RobAStBase/R/oneStepEstimator.R 2018-08-11 14:59:35 UTC (rev 1127)
+++ branches/robast-1.2/pkg/RobAStBase/R/oneStepEstimator.R 2018-08-12 00:07:24 UTC (rev 1128)
@@ -6,7 +6,8 @@
useLast = getRobAStBaseOption("kStepUseLast"),
withUpdateInKer = getRobAStBaseOption("withUpdateInKer"),
IC.UpdateInKer = getRobAStBaseOption("IC.UpdateInKer"),
- na.rm = TRUE, startArgList = NULL, withMakeIC = FALSE, ...){
+ na.rm = TRUE, startArgList = NULL, withMakeIC = FALSE, ...,
+ E.argList = NULL){
es.call <- match.call()
es.call[[1]] <- as.name("oneStepEstimator")
@@ -17,7 +18,8 @@
erg <- kStepEstimator(x = x, IC = IC, start = start, steps = 1L,
useLast = useLast, withUpdateInKer = withUpdateInKer,
IC.UpdateInKer = IC.UpdateInKer, na.rm = na.rm,
- startArgList = startArgList, withMakeIC = withMakeIC, ...)
+ startArgList = startArgList, withMakeIC = withMakeIC, ...,
+ E.argList = E.argList)
Infos(erg) <- gsub("kStep","oneStep", Infos(erg))
erg at estimate.call <- es.call
return(erg)
Modified: branches/robast-1.2/pkg/RobAStBase/R/optIC.R
===================================================================
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/robast -r 1128
More information about the Robast-commits
mailing list