[Robast-commits] r1149 - in branches/robast-1.2/pkg/RobAStBase: R inst man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Aug 16 13:16:09 CEST 2018
Author: ruckdeschel
Date: 2018-08-16 13:16:09 +0200 (Thu, 16 Aug 2018)
New Revision: 1149
Modified:
branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.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/inst/NEWS
branches/robast-1.2/pkg/RobAStBase/man/checkIC.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/makeIC-methods.Rd
Log:
[RobAStBase] branch 1.2
+ getboundedIC, getRiskIC for signature (IC, asCov, missing, L2ParamFamily),
checkIC and makeIC gain argument diagnostic to be able to show diagnostic
information on integrations
Modified: branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R
===================================================================
--- branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R 2018-08-16 08:07:00 UTC (rev 1148)
+++ branches/robast-1.2/pkg/RobAStBase/R/CheckMakeIC.R 2018-08-16 11:16:09 UTC (rev 1149)
@@ -1,6 +1,6 @@
## new helper function for make and check IC to speed up things
-.preparedirectCheckMakeIC <- function(L2Fam, IC, ...){
+.preparedirectCheckMakeIC <- function(L2Fam, IC, ..., diagnostic = FALSE){
dims <- length(L2Fam at param)
trafo <- trafo(L2Fam at param)
@@ -14,21 +14,28 @@
IC.v <- as(diag(nrvalues) %*% IC at Curve, "EuclRandVariable")
L2deriv <- as(diag(dims) %*% L2Fam at L2deriv, "EuclRandVariable")
+ diagn <- if(diagnostic) vector("list",(nrvalues+3)*nrvalues/2) else NULL
+ if(diagnostic) dotsI$diagnostic <- TRUE
+ k <- 0
+
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)
+ res[i] <- buf <- do.call(E, Eargs)
+ if(diagnostic){ k <- k + 1; diagn[[k]] <- attr(buf,"diagnostic") }
}
+ if(diagnostic) attr(res, "diagnostic") <- diagn[1:nrvalues]
-
erg <- matrix(0, ncol = dims, nrow = nrvalues)
for(i in 1:nrvalues)
for(j in 1:dims){
integrandA <- function(x)IC.v at Map[[i]](x)*L2deriv at Map[[j]](x)
Eargs <- c(list(object = Distr, fun = integrandA),dotsI)
- erg[i, j] <- do.call(E, Eargs)
+ erg[i, j] <- buf <- do.call(E, Eargs)
+ if(diagnostic){ k <- k + 1; diagn[[k]] <- attr(buf,"diagnostic") }
}
+ if(diagnostic) attr(erg, "diagnostic") <- diagn[-(1:nrvalues)]
return(list(E.IC=res,E.IC.L=erg))
}
@@ -37,22 +44,22 @@
## check centering and Fisher consistency
setMethod("checkIC", signature(IC = "IC", L2Fam = "missing"),
- function(IC, out = TRUE, ...){
+ function(IC, out = TRUE, ..., diagnostic = FALSE){
L2Fam <- eval(IC at CallL2Fam)
getMethod("checkIC", signature(IC = "IC", L2Fam = "L2ParamFamily"))(
- IC = IC, L2Fam = L2Fam, out = out, ...)
+ IC = IC, L2Fam = L2Fam, out = out, ..., diagnostic = diagnostic)
})
## check centering and Fisher consistency
setMethod("checkIC", signature(IC = "IC", L2Fam = "L2ParamFamily"),
- function(IC, L2Fam, out = TRUE, ...){
+ function(IC, L2Fam, out = TRUE, ..., diagnostic = FALSE){
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, ...)
+ res <- .preparedirectCheckMakeIC(L2Fam, IC, ..., diagnostic = diagnostic)
cent <- res$E.IC
if(out)
@@ -71,13 +78,18 @@
prec <- max(abs(cent), abs(consist))
names(prec) <- "maximum deviation"
+ if(diagnostic && out){
+ print(attr(res$E.IC,"diagnostic"))
+ print(attr(res$E.IC.L,"diagnostic"))
+ }
+
return(prec)
})
## make some L2function a pIC at a model
setMethod("makeIC", signature(IC = "IC", L2Fam = "L2ParamFamily"),
- function(IC, L2Fam, ...){
+ function(IC, L2Fam, ..., diagnostic = FALSE){
dims <- length(L2Fam at param)
if(dimension(IC at Curve) != dims)
@@ -89,8 +101,13 @@
trafo <- trafo(L2Fam at param)
- res <- .preparedirectCheckMakeIC(L2Fam, IC, ...)
+ res <- .preparedirectCheckMakeIC(L2Fam, IC, ..., diagnostic = diagnostic)
+ if(diagnostic){
+ print(attr(res$E.IC,"diagnostic"))
+ print(attr(res$E.IC.L,"diagnostic"))
+ }
+
IC1 <- as(diag(dimension(IC at Curve)) %*% IC at Curve, "EuclRandVariable")
cent <- res$E.IC
@@ -119,14 +136,14 @@
## make some L2function a pIC at a model
setMethod("makeIC", signature(IC = "IC", L2Fam = "missing"),
- function(IC, ...){
+ function(IC, ..., diagnostic = FALSE){
L2Fam <- eval(IC at CallL2Fam)
getMethod("makeIC", signature(IC = "IC", L2Fam = "L2ParamFamily"))(
- IC = IC, L2Fam = L2Fam, ...)
+ IC = IC, L2Fam = L2Fam, ..., diagnostic = diagnostic)
})
setMethod("makeIC", signature(IC = "list", L2Fam = "L2ParamFamily"),
- function(IC, L2Fam, forceIC = TRUE, name, Risks, Infos, modifyIC = NULL,...){
+ function(IC, L2Fam, forceIC = TRUE, name, Risks, Infos, modifyIC = NULL,..., diagnostic = FALSE){
mc <- match.call(call = sys.call(sys.parent(1)), expand.dots = FALSE)[-1]
mc0 <- as.list(mc)
mc0$IC <- NULL
@@ -142,14 +159,15 @@
mc0$CallL2Fam <- substitute(L2Fam at fam.call)
IC.0 <- do.call(.IC,mc0)
- if(forceIC) IC.0 <- makeIC(IC.0, L2Fam,...)
+ if(forceIC) IC.0 <- makeIC(IC.0, L2Fam,..., diagnostic = diagnostic)
return(IC.0)
})
setMethod("makeIC", signature(IC = "function", L2Fam = "L2ParamFamily"),
- function(IC, L2Fam, forceIC = TRUE, name, Risks, Infos, modifyIC = NULL,...){
+ function(IC, L2Fam, forceIC = TRUE, name, Risks, Infos,
+ modifyIC = NULL,..., diagnostic = FALSE){
mc <- match.call(call = sys.call(sys.parent(1)), expand.dots = FALSE)[-1]
mc0 <- as.list(mc)
mc0$IC <- NULL
Modified: branches/robast-1.2/pkg/RobAStBase/R/getRiskIC.R
===================================================================
--- branches/robast-1.2/pkg/RobAStBase/R/getRiskIC.R 2018-08-16 08:07:00 UTC (rev 1148)
+++ branches/robast-1.2/pkg/RobAStBase/R/getRiskIC.R 2018-08-16 11:16:09 UTC (rev 1149)
@@ -26,12 +26,14 @@
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, ...,
+ diagnostic = FALSE){
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 <- .filterEargsWEargList(list(...))
if(!is.null(dotsI$useApply)) dotsI$useApply <- FALSE
+ dotsI$diagnostic <- diagnostic
if(missing(withCheck)) withCheck <- TRUE
IC1 <- as(diag(dimension(IC at Curve)) %*% IC at Curve, "EuclRandVariable")
@@ -46,16 +48,23 @@
Cova <- matrix(0, ncol = nrvalues, nrow = nrvalues)
+ diagn <- if(diagnostic) vector("list",nrvalues*(nrvalues+1)/2) else NULL
+ k <- 0
for(i in 1:nrvalues){
for(j in i:nrvalues){
- Cova[i,j] <- do.call(E,c(list(object = Distr,
+ Cova[i,j] <- buf <- 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))
+ if(diagnostic){
+ k <- k + 1
+ diagn[[k]] <- attr(buf, "diagnostic")
+ }
}
}
Cova[col(Cova) < row(Cova)] <- t(Cova)[col(Cova) < row(Cova)]
# if(withCheck) .checkICWithWarning(IC, L2Fam, tol, ...)
+ if(diagnostic) attr(Cova,"diagnostic") <- diagn
return(list(asCov = list(distribution = .getDistr(L2Fam), value = Cova)))
})
Modified: branches/robast-1.2/pkg/RobAStBase/R/getboundedIC.R
===================================================================
--- branches/robast-1.2/pkg/RobAStBase/R/getboundedIC.R 2018-08-16 08:07:00 UTC (rev 1148)
+++ branches/robast-1.2/pkg/RobAStBase/R/getboundedIC.R 2018-08-16 11:16:09 UTC (rev 1149)
@@ -1,4 +1,4 @@
-getBoundedIC <- function(L2Fam, D=trafo(L2Fam at param),...){
+getBoundedIC <- function(L2Fam, D=trafo(L2Fam at param),..., diagnostic = FALSE){
dotsI <- .filterEargsWEargList(list(...))
if(is.null(dotsI$useApply)) dotsI$useApply <- FALSE
@@ -33,21 +33,35 @@
cent <- numeric(dims)
stand.0 <- matrix(0,dims,dims)
+ diagn <- if(diagnostic) vector("list", dims*(dims+3)/2) else NULL
+ k <- 0
+ if(diagnostic) dotsI$diagnostic <- TRUE
+
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)
+ cent[i] <- buf <- do.call(E,Eargs)
+ if(diagnostic){
+ k <- k + 1
+ diagn[[k]] <- attr(buf,"diagnostic")
+ }
}
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[i,j] <- buf <- do.call(E,Eargs)
+ if(diagnostic){
+ k <- k + 1
+ diagn[[k]] <- attr(buf,"diagnostic")
+ }
}
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
- return(as(stand %*% L2w0, "EuclRandVariable"))
+ res <- as(stand %*% L2w0, "EuclRandVariable")
+ if(diagnostic) attr(res,"diagnostic") <- diagn
+ return(res)
}
Modified: branches/robast-1.2/pkg/RobAStBase/inst/NEWS
===================================================================
--- branches/robast-1.2/pkg/RobAStBase/inst/NEWS 2018-08-16 08:07:00 UTC (rev 1148)
+++ branches/robast-1.2/pkg/RobAStBase/inst/NEWS 2018-08-16 11:16:09 UTC (rev 1149)
@@ -93,6 +93,9 @@
overwrites existing entries).
+ getboundedIC now uses coordinate-wise integration with useApply = FALSE and
only computing the upper half of E LL'w
++ getboundedIC, getRiskIC for signature (IC, asCov, missing, L2ParamFamily),
+ checkIC and makeIC gain argument diagnostic to be able to show diagnostic
+ information on integrations
#######################################
version 1.1
Modified: branches/robast-1.2/pkg/RobAStBase/man/checkIC.Rd
===================================================================
--- branches/robast-1.2/pkg/RobAStBase/man/checkIC.Rd 2018-08-16 08:07:00 UTC (rev 1148)
+++ branches/robast-1.2/pkg/RobAStBase/man/checkIC.Rd 2018-08-16 11:16:09 UTC (rev 1149)
@@ -10,14 +10,16 @@
}
\usage{
checkIC(IC, L2Fam, ...)
-\S4method{checkIC}{IC,missing}(IC, out = TRUE, ...)
-\S4method{checkIC}{IC,L2ParamFamily}(IC, L2Fam, out = TRUE,...)
+\S4method{checkIC}{IC,missing}(IC, out = TRUE, ..., diagnostic = FALSE)
+\S4method{checkIC}{IC,L2ParamFamily}(IC, L2Fam, out = TRUE,..., diagnostic = FALSE)
}
\arguments{
\item{IC}{ object of class \code{"IC"} }
\item{L2Fam}{ L2-differentiable family of probability measures. }
\item{out}{ logical: Should the values of the checks be printed out?}
\item{\dots}{ additional parameters }
+ \item{diagnostic}{ logical; if \code{TRUE} and \code{out==TRUE},
+ diagnostic information on the integration is printed. }
}
\details{
The precisions of the centering and the Fisher consistency
Modified: branches/robast-1.2/pkg/RobAStBase/man/getBoundedIC.Rd
===================================================================
--- branches/robast-1.2/pkg/RobAStBase/man/getBoundedIC.Rd 2018-08-16 08:07:00 UTC (rev 1148)
+++ branches/robast-1.2/pkg/RobAStBase/man/getBoundedIC.Rd 2018-08-16 11:16:09 UTC (rev 1149)
@@ -6,12 +6,15 @@
Generates a bounded influence curve.
}
\usage{
-getBoundedIC(L2Fam, D=trafo(L2Fam at param), ...)
+getBoundedIC(L2Fam, D=trafo(L2Fam at param), ..., diagnostic = FALSE)
}
\arguments{
\item{L2Fam}{object of class \code{"L2ParamFamily"}}
\item{D}{matrix with as many columns as \code{length(L2Fam at param)}}
\item{...}{further arguments to be passed to \code{E}}
+ \item{diagnostic}{ logical; if \code{TRUE}, the return value obtains
+ an attribute \code{"diagnostic"} with diagnostic information on the
+ integration. }
}
%\details{}
\value{(a bounded) pIC (to matrix \code{D}) given as object of class
Modified: branches/robast-1.2/pkg/RobAStBase/man/getRiskIC.Rd
===================================================================
--- branches/robast-1.2/pkg/RobAStBase/man/getRiskIC.Rd 2018-08-16 08:07:00 UTC (rev 1148)
+++ branches/robast-1.2/pkg/RobAStBase/man/getRiskIC.Rd 2018-08-16 11:16:09 UTC (rev 1149)
@@ -24,7 +24,7 @@
tol = .Machine$double.eps^0.25, withCheck = TRUE, ...)
\S4method{getRiskIC}{IC,asCov,missing,L2ParamFamily}(IC, risk, L2Fam,
- tol = .Machine$double.eps^0.25, withCheck = TRUE, ...)
+ tol = .Machine$double.eps^0.25, withCheck = TRUE, ..., diagnostic = FALSE)
\S4method{getRiskIC}{IC,trAsCov,missing,missing}(IC, risk,
tol = .Machine$double.eps^0.25, withCheck = TRUE, ...)
@@ -62,6 +62,9 @@
\item{cont}{ "left" or "right". }
\item{withCheck}{logical: should a call to \code{checkIC} be done to
check accuracy (defaults to \code{TRUE}).}
+ \item{diagnostic}{ logical; if \code{TRUE}, the return value obtains
+ an attribute \code{"diagnostic"} with diagnostic information on the
+ integration. }
}
\details{To make sure that the results are valid, it is recommended
to include an additional check of the IC properties of \code{IC}
Modified: branches/robast-1.2/pkg/RobAStBase/man/makeIC-methods.Rd
===================================================================
--- branches/robast-1.2/pkg/RobAStBase/man/makeIC-methods.Rd 2018-08-16 08:07:00 UTC (rev 1148)
+++ branches/robast-1.2/pkg/RobAStBase/man/makeIC-methods.Rd 2018-08-16 11:16:09 UTC (rev 1149)
@@ -14,11 +14,11 @@
\usage{
makeIC(IC, L2Fam, ...)
%\S4method{makeIC}{IC,missing}(IC, ...)
-\S4method{makeIC}{IC,L2ParamFamily}(IC, L2Fam, ...)
+\S4method{makeIC}{IC,L2ParamFamily}(IC, L2Fam, ..., diagnostic = FALSE)
\S4method{makeIC}{list,L2ParamFamily}(IC, L2Fam, forceIC = TRUE, name, Risks,
- Infos, modifyIC = NULL, ...)
+ Infos, modifyIC = NULL, ..., diagnostic = FALSE)
\S4method{makeIC}{function,L2ParamFamily}(IC, L2Fam, forceIC = TRUE, name,
- Risks, Infos, modifyIC = NULL, ...)
+ Risks, Infos, modifyIC = NULL, ..., diagnostic = FALSE)
}
\arguments{
\item{IC}{ object of class \code{"IC"} for signature \code{IC="IC"}, respectively
@@ -43,6 +43,8 @@
class \code{"IC"}. This function is mainly used for internal
computations! }
\item{\dots}{ additional parameters to be passed to expectation \code{E} }
+ \item{diagnostic}{ logical; if \code{TRUE},
+ diagnostic information on the integration is printed. }
}
\value{An IC of class \code{"IC"} at the model.}
\section{Methods}{\describe{
More information about the Robast-commits
mailing list