[Robast-commits] r1185 - in pkg/ROptEst: . R inst inst/scripts man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sat Mar 2 17:06:03 CET 2019
Author: ruckdeschel
Date: 2019-03-02 17:06:02 +0100 (Sat, 02 Mar 2019)
New Revision: 1185
Added:
pkg/ROptEst/R/CheckMakeContIC.R
pkg/ROptEst/R/RMXEOMSEMBREOBRE.R
pkg/ROptEst/R/getStartIClcsc.R
pkg/ROptEst/man/ORobEstimate-class.Rd
pkg/ROptEst/man/RMXEOMSEMBREOBRE.Rd
pkg/ROptEst/man/checkmakeIC.Rd
Removed:
pkg/ROptEst/R/RMXEOMSEMBREOBRE.R
pkg/ROptEst/man/ORobEstimate-class.Rd
pkg/ROptEst/man/RMXEOMSEMBREOBRE.Rd
Modified:
pkg/ROptEst/DESCRIPTION
pkg/ROptEst/NAMESPACE
pkg/ROptEst/R/AllGeneric.R
pkg/ROptEst/R/L1L2normL2deriv.R
pkg/ROptEst/R/LowerCaseMultivariate.R
pkg/ROptEst/R/cniperCont.R
pkg/ROptEst/R/comparePlot.R
pkg/ROptEst/R/getAsRisk.R
pkg/ROptEst/R/getComp.R
pkg/ROptEst/R/getInfCent.R
pkg/ROptEst/R/getInfClip.R
pkg/ROptEst/R/getInfGamma.R
pkg/ROptEst/R/getInfLM.R
pkg/ROptEst/R/getInfRad.R
pkg/ROptEst/R/getInfRobIC_asAnscombe.R
pkg/ROptEst/R/getInfRobIC_asBias.R
pkg/ROptEst/R/getInfRobIC_asCov.R
pkg/ROptEst/R/getInfRobIC_asGRisk.R
pkg/ROptEst/R/getInfRobIC_asHampel.R
pkg/ROptEst/R/getInfStand.R
pkg/ROptEst/R/getInfV.R
pkg/ROptEst/R/getMaxIneff.R
pkg/ROptEst/R/getModifyIC.R
pkg/ROptEst/R/getRadius.R
pkg/ROptEst/R/getReq.R
pkg/ROptEst/R/getRiskIC.R
pkg/ROptEst/R/getStartIC.R
pkg/ROptEst/R/internal.roptest.R
pkg/ROptEst/R/leastFavorableRadius.R
pkg/ROptEst/R/optIC.R
pkg/ROptEst/R/optRisk.R
pkg/ROptEst/R/radiusMinimaxIC.R
pkg/ROptEst/R/roptest.new.R
pkg/ROptEst/R/updateNorm.R
pkg/ROptEst/inst/NEWS
pkg/ROptEst/inst/scripts/MBRE.R
pkg/ROptEst/man/0ROptEst-package.Rd
pkg/ROptEst/man/getBiasIC.Rd
pkg/ROptEst/man/getInfCent.Rd
pkg/ROptEst/man/getInfClip.Rd
pkg/ROptEst/man/getInfGamma.Rd
pkg/ROptEst/man/getInfRad.Rd
pkg/ROptEst/man/getInfStand.Rd
pkg/ROptEst/man/getInfV.Rd
pkg/ROptEst/man/getMaxIneff.Rd
pkg/ROptEst/man/getReq.Rd
pkg/ROptEst/man/getRiskIC.Rd
pkg/ROptEst/man/getStartIC-methods.Rd
pkg/ROptEst/man/getinfLM.Rd
pkg/ROptEst/man/inputGenerator.Rd
pkg/ROptEst/man/internals.Rd
pkg/ROptEst/man/leastFavorableRadius.Rd
pkg/ROptEst/man/minmaxBias.Rd
pkg/ROptEst/man/optIC.Rd
pkg/ROptEst/man/robest.Rd
pkg/ROptEst/man/roptest.Rd
Log:
preparation for release of 1.2: merged back ROptEst from branch 1.2 to trunk
Modified: pkg/ROptEst/DESCRIPTION
===================================================================
--- pkg/ROptEst/DESCRIPTION 2019-03-02 16:05:00 UTC (rev 1184)
+++ pkg/ROptEst/DESCRIPTION 2019-03-02 16:06:02 UTC (rev 1185)
@@ -1,11 +1,11 @@
Package: ROptEst
-Version: 1.1.0
-Date: 2018-08-01
+Version: 1.2.0
+Date: 2019-03-01
Title: Optimally Robust Estimation
Description: Optimally robust estimation in general smoothly parameterized models using S4
classes and methods.
-Depends: R(>= 2.14.0), methods, distr(>= 2.5.2), distrEx(>= 2.5), distrMod(>= 2.5.2),
- RandVar(>= 0.9.2), RobAStBase(>= 1.0)
+Depends: R(>= 2.14.0), methods, distr(>= 2.7.0), distrEx(>= 2.8.0), distrMod(>= 2.8.0),
+ RandVar(>= 1.1.0), RobAStBase(>= 1.2.0)
Imports: startupmsg, MASS, stats, graphics, utils, grDevices
Suggests: RobLox
Authors at R: c(person("Matthias", "Kohl", role=c("cre", "cph"),
@@ -19,4 +19,4 @@
Encoding: latin1
LastChangedDate: {$LastChangedDate$}
LastChangedRevision: {$LastChangedRevision$}
-VCS/SVNRevision: 1081
+VCS/SVNRevision: 1178
Modified: pkg/ROptEst/NAMESPACE
===================================================================
--- pkg/ROptEst/NAMESPACE 2019-03-02 16:05:00 UTC (rev 1184)
+++ pkg/ROptEst/NAMESPACE 2019-03-02 16:06:02 UTC (rev 1185)
@@ -11,7 +11,8 @@
"title")
importFrom("stats", "complete.cases", "dnorm", "na.omit", "optim",
"optimize", "pnorm", "qnorm", "uniroot")
-importFrom("utils", "read.csv", "read.table", "str", "write.table")
+importFrom("utils", "read.csv", "read.table", "str", "write.table",
+ "getFromNamespace")
importFrom("graphics", "abline")
importFrom("MASS", "ginv")
@@ -38,7 +39,8 @@
"getModifyIC")
exportMethods("updateNorm", "scaleUpdateIC", "eff",
"get.asGRisk.fct", "getStartIC", "plot",
- "comparePlot", "getRiskFctBV", "roptestCall")
+ "comparePlot", "getRiskFctBV", "roptestCall",
+ "checkIC", "makeIC", "kStepTimings")
export("getL2normL2deriv",
"asAnscombe", "asL1", "asL4",
"getReq", "getMaxIneff", "getRadius")
Modified: pkg/ROptEst/R/AllGeneric.R
===================================================================
--- pkg/ROptEst/R/AllGeneric.R 2019-03-02 16:05:00 UTC (rev 1184)
+++ pkg/ROptEst/R/AllGeneric.R 2019-03-02 16:06:02 UTC (rev 1185)
@@ -93,3 +93,6 @@
if(!isGeneric("roptestCall")){
setGeneric("roptestCall", function(object) standardGeneric("roptestCall"))
}
+if(!isGeneric("kStepTimings")){
+ setGeneric("kStepTimings", function(object, ...) standardGeneric("kStepTimings"))
+}
Copied: pkg/ROptEst/R/CheckMakeContIC.R (from rev 1178, branches/robast-1.2/pkg/ROptEst/R/CheckMakeContIC.R)
===================================================================
--- pkg/ROptEst/R/CheckMakeContIC.R (rev 0)
+++ pkg/ROptEst/R/CheckMakeContIC.R 2019-03-02 16:06:02 UTC (rev 1185)
@@ -0,0 +1,236 @@
+#if(FALSE){
+## faster check for ContICs
+
+setMethod("checkIC", signature(IC = "ContIC", L2Fam = "L2ParamFamily"),
+ function(IC, L2Fam, out = TRUE, forceContICMethod = FALSE, ..., 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'")
+
+ res <- .prepareCheckMakeIC(L2Fam, w = IC at weight, forceContICMethod, ..., diagnostic = diagnostic)
+ ## if it pays off to use symmetry/ to compute integrals in L2deriv space
+ ## we compute the following integrals:
+ ## G1 = E w, G2 = E Lambda w, G3 = E Lambda Lambda' w
+ ## we want to compute:
+ ## Delta1 = E (A Lambda-a) w, Delta2 = E (A Lambda-a) Lambda' w
+ ## where A = stand(IC), a=cent(IC)
+ ## hence Delta1 = A G2 - a G1, Delta2 = A G3 - a G2'
+ ### otherwise the return value is NULL and we use the standard method
+
+ if(is.null(res))
+ return(getMethod("checkIC", signature(IC = "IC",
+ L2Fam = "L2ParamFamily"))(IC,L2Fam, out = out, ..., diagnostic = diagnostic))
+
+
+ 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)
+ Delta2 <- Delta2 - trafo(L2Fam)
+
+ if(out)
+ cat("precision of centering:\t", Delta1, "\n")
+
+ if(out){
+ cat("precision of Fisher consistency:\n")
+ print(Delta2)
+ cat("precision of Fisher consistency - relative error [%]:\n")
+ print(100*Delta2/trafo)
+
+ if(diagnostic){
+ print(attr(res$G1, "diagnostic"))
+ print(attr(res$G2, "diagnostic"))
+ print(attr(res$G3, "diagnostic"))
+ }
+ }
+
+ prec <- max(abs(Delta1), abs(Delta2))
+ names(prec) <- "maximum deviation"
+
+ if(diagnostic) attr(prec, "diagnostic") <- c(attr(res$G1, "diagnostic"),
+ attr(res$G2, "diagnostic"), attr(res$G3, "diagnostic"))
+ return(prec)
+ })
+
+## make some L2function a pIC at a model
+setMethod("makeIC", signature(IC = "ContIC", L2Fam = "L2ParamFamily"),
+ function(IC, L2Fam, forceContICMethod = FALSE, ..., 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'")
+
+ dims <- nrow(trafo(L2Fam))
+ if(dimension(IC at Curve) != dims)
+ stop("Dimension of IC and parameter must be equal")
+
+ res <- .prepareCheckMakeIC(L2Fam, w = IC at weight, forceContICMethod, ..., diagnostic = diagnostic)
+
+ if(diagnostic &&!is.null(res)){
+ print(attr(res$G1, "diagnostic"))
+ print(attr(res$G2, "diagnostic"))
+ print(attr(res$G3, "diagnostic"))
+ }
+
+ ## if it pays off to use symmetry/ to compute integrals in L2deriv space
+ ## we compute the following integrals:
+ ## G1 = E w, G2 = E Lambda w, G3 = E Lambda Lambda' w
+ ## we want to compute:
+ ## Delta1 = E (A Lambda-a) w, Delta2 = E (A Lambda-a) Lambda' w
+ ## where A = stand(IC), a=cent(IC)
+ ## hence Delta1 = A G2 - a G1, Delta2 = A G3 - a G2'
+ ### otherwise the return value is NULL and we use the standard method
+
+ if(is.null(res))
+ return(getMethod("makeIC", signature(IC = "IC",
+ L2Fam = "L2ParamFamily"))(IC,L2Fam,..., diagnostic = diagnostic))
+
+ G1 <- res$G1; G2 <- res$G2; G3 <- res$G3
+ trafO <- trafo(L2Fam at param)
+ nrvalues <- nrow(trafO)
+ dims <- ncol(trafO)
+
+ 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.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(IC1.l[[i]]) <- substitute( c((IC1.s(x))[i,]), list(IC1.s=IC1.f, i=i))
+ }
+ IC1.c <- EuclRandVariable(Map = IC1.l, Domain = Domain(IC at Curve[[1]]),
+ Range = Reals())
+
+ cIC1 <- new("ContIC")
+ 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
+ cIC1 at clip <- IC at clip
+ cIC1 at cent <- cent1
+ cIC1 at stand <- stand1
+ cIC1 at lowerCase <- IC at lowerCase
+ cIC1 at neighborRadius <- IC at neighborRadius
+ cIC1 at weight <- IC at weight
+ cIC1 at biastype <- IC at biastype
+ cIC1 at normtype <- IC at normtype
+ cIC1 at modifyIC <- IC at modifyIC
+ addInfo(cIC1) <- c("IC<-",
+ "generated by affine linear trafo to enforce consistency")
+
+ if(diagnostic) attr(cIC1, "diagnostic") <- c(attr(res$G1, "diagnostic"),
+ attr(res$G2, "diagnostic"), attr(res$G3, "diagnostic"))
+
+ return(cIC1)
+ })
+
+.prepareCheckMakeIC <- function(L2Fam, w, forceContICMethod, ..., diagnostic = FALSE){
+
+ dims <- length(L2Fam at param)
+ trafo <- trafo(L2Fam at param)
+ nrvalues <- nrow(trafo)
+
+ z.comp <- rep(TRUE,dims)
+ A.comp <- matrix(rep(TRUE,dims^2),nrow=dims)
+ to.comp.i <- (dims+1)*(dims+2)/2
+ to.comp.a <- (dims+1)*nrvalues
+
+ L2deriv <- as(diag(dims) %*% L2Fam at L2deriv, "EuclRandVariable")
+
+ z.comp <- rep(TRUE,dims)
+ A.comp <- matrix(TRUE, dims, dims)
+# print(list(z.comp,A.comp))
+ # otherwise if nrvalues > 1 # formerly: trafo == unitMatrix #
+ # may use symmetry info
+ if(dims>1){
+ comp <- .getComp(L2deriv, L2Fam at distrSymm, L2Fam at L2derivSymm, L2Fam at L2derivDistrSymm)
+ z.comp <- comp$"z.comp"
+ A.comp <- comp$"A.comp"
+ t.comp.i <- sum(z.comp)+sum(A.comp)+1
+ }
+
+ if(to.comp.a < to.comp.i && !forceContICMethod) return(NULL)
+
+
+ res <- .getG1G2G3Stand(L2deriv = L2deriv, Distr = L2Fam at distribution,
+ A.comp = A.comp, z.comp = z.comp, w = w, ...,
+ diagnostic = diagnostic)
+ return(res)
+}
+
+
+
+.getG1G2G3Stand <- function(L2deriv, Distr, A.comp, z.comp, w, ..., diagnostic = FALSE){
+
+ dotsI <- .filterEargs(list(...))
+ if(is.null(dotsI$useApply)) dotsI$useApply <- FALSE
+
+ w.fct <- function(x){
+ weight(w)(evalRandVar(L2deriv, as.matrix(x)) [,,1])
+ }
+
+
+ integrand2 <- function(x, L2.i){
+ return(L2.i(x)*w.fct(x))
+ }
+
+ diagn <- if(diagnostic) vector("list", sum(z.comp)+sum(A.comp))
+ if(diagnostic) dotsI$diagnostic <- TRUE
+ Eargs <- c(list(object = Distr, fun = w.fct), dotsI)
+ res1 <- do.call(E,Eargs)
+
+ k <- 0
+ nrvalues <- length(L2deriv)
+ res2 <- numeric(nrvalues)
+ for(i in 1:nrvalues){
+ if(z.comp[i]){
+ Eargs <- c(list(object = Distr, fun = integrand2,
+ L2.i = L2deriv at Map[[i]]), dotsI)
+ res2[i] <- buf <- do.call(E,Eargs)
+ if(diagnostic){k <- k + 1; diagn[[k]] <- attr(buf,"diagnostic")}
+ }else{
+ res2[i] <- 0
+ }
+ }
+ if(diagnostic) {k1 <- k; attr(res2, "diagnostic") <- diagn[(1:k1)]}
+ cent <- res2/res1
+
+ integrandA <- function(x, L2.i, L2.j, i, j){
+ return((L2.i(x) - cent[i])*(L2.j(x) - cent[j])*w.fct(x = x))
+ }
+
+ nrvalues <- length(L2deriv)
+ erg <- matrix(0, ncol = nrvalues, nrow = nrvalues)
+
+ for(i in 1:nrvalues){
+ for(j in i:nrvalues){
+ if(A.comp[i,j]){
+ Eargs <- c(list(object = Distr, fun = integrandA,
+ L2.i = L2deriv at Map[[i]],
+ L2.j = L2deriv at Map[[j]], i = i, j = j), dotsI)
+ erg[i, j] <- buf <- do.call(E,Eargs)
+ if(diagnostic){k <- k + 1; diagn[[k]] <- attr(buf,"diagnostic")}
+ }
+ }
+ }
+ erg[col(erg) < row(erg)] <- t(erg)[col(erg) < row(erg)]
+ if(diagnostic) {k1 <- k; attr(erg, "diagnostic") <- diagn[-(1:k1)]}
+
+ return(list(G1=res1,G2=res2, G3=erg))
+ }
+
+
+
+
+
+#}
Modified: pkg/ROptEst/R/L1L2normL2deriv.R
===================================================================
--- pkg/ROptEst/R/L1L2normL2deriv.R 2019-03-02 16:05:00 UTC (rev 1184)
+++ pkg/ROptEst/R/L1L2normL2deriv.R 2019-03-02 16:06:02 UTC (rev 1185)
@@ -8,6 +8,10 @@
setMethod("getL1normL2deriv", signature(L2deriv = "RealRandVariable"),
function(L2deriv, cent, stand, Distr, normtype, ...){
+
+ dotsI <- .filterEargsWEargList(list(...))
+ if(is.null(dotsI$useApply)) dotsI$useApply <- FALSE
+
integrandG <- function(x, L2, stand, cent){
X <- evalRandVar(L2, as.matrix(x))[,,1] - cent
Y <- apply(X, 2, "%*%", t(stand))
@@ -15,6 +19,7 @@
return((res > 0)*res)
}
- return(E(object = Distr, fun = integrandG, L2 = L2deriv,
- stand = stand, cent = cent, useApply = FALSE))
+
+ return(do.call(E, c(list(object = Distr, fun = integrandG, L2 = L2deriv,
+ stand = stand, cent = cent),dotsI)))
})
Modified: pkg/ROptEst/R/LowerCaseMultivariate.R
===================================================================
--- pkg/ROptEst/R/LowerCaseMultivariate.R 2019-03-02 16:05:00 UTC (rev 1184)
+++ pkg/ROptEst/R/LowerCaseMultivariate.R 2019-03-02 16:06:02 UTC (rev 1185)
@@ -1,15 +1,18 @@
.LowerCaseMultivariate <- function(L2deriv, neighbor, biastype,
normtype, Distr, Finfo, trafo, z.start = NULL,
A.start = NULL, z.comp = NULL, A.comp = NULL, maxiter, tol,
- verbose = NULL){
+ verbose = NULL, ...){
+ dotsI <- .filterEargsWEargList(list(...))
+ if(is.null(dotsI$useApply)) dotsI$useApply <- FALSE
+
if(missing(verbose)|| is.null(verbose))
verbose <- getRobAStBaseOption("all.verbose")
w <- new("HampelWeight")
if(is.null(z.start)) z.start <- numeric(ncol(trafo))
- if(is.null(A.start)) A.start <- trafo%*%solve(as.matrix(Finfo))
+ if(is.null(A.start)) A.start <- trafo%*%distr::solve(as.matrix(Finfo))
if(is.null(A.comp))
A.comp <- matrix(TRUE, nrow = nrow(trafo), ncol = ncol(trafo))
if(is.null(z.comp))
@@ -59,8 +62,8 @@
w <<- w0
}
- E1 <- E(object = Distr, fun = abs.fct, L2 = L2deriv, stand = A,
- cent = z, normtype.0 = normtype, useApply = FALSE)
+ E1 <- do.call(E,c(list(object = Distr, fun = abs.fct, L2 = L2deriv, stand = A,
+ cent = z, normtype.0 = normtype), dotsI))
stA <- if (is(normtype,"QFNorm"))
QuadForm(normtype)%*%A else A
# erg <- E1/sum(diag(stA %*% t(trafo)))
@@ -101,15 +104,18 @@
.LowerCaseMultivariateTV <- function(L2deriv, neighbor, biastype,
normtype, Distr, Finfo, trafo,
A.start = NULL, maxiter, tol,
- verbose = NULL){
+ verbose = NULL, ...){
+ dotsI <- .filterEargsWEargList(list(...))
+ if(is.null(dotsI$useApply)) dotsI$useApply <- FALSE
+
if(missing(verbose)|| is.null(verbose))
verbose <- getRobAStBaseOption("all.verbose")
w <- new("BdStWeight")
k <- ncol(trafo)
- if(is.null(A.start)) A.start <- trafo%*%solve(Finfo)
+ if(is.null(A.start)) A.start <- trafo%*%distr::solve(Finfo)
pos.fct <- function(x, L2, stand){
X <- evalRandVar(L2, as.matrix(x))[,,1]
@@ -124,8 +130,8 @@
p <- 1
A <- matrix(param, ncol = k, nrow = 1)
# print(A)
- E1 <- E(object = Distr, fun = pos.fct, L2 = L2deriv, stand = A,
- useApply = FALSE)
+ E1 <- do.call(E, c(list( object = Distr, fun = pos.fct,
+ L2 = L2deriv, stand = A), dotsI))
erg <- E1/sum(diag(A %*% t(trafo)))
return(erg)
}
@@ -144,10 +150,10 @@
Y <- as.numeric(A %*% X)
return(as.numeric(pr.sign*Y>0))
}
- p.p <- E(object = Distr, fun = pr.fct, L2 = L2deriv,
- useApply = FALSE, pr.sign = 1)
- m.p <- E(object = Distr, fun = pr.fct, L2 = L2deriv,
- useApply = FALSE, pr.sign = -1)
+ p.p <- do.call(E, c(list( object = Distr, fun = pr.fct, L2 = L2deriv,
+ pr.sign = 1), dotsI))
+ m.p <- do.call(E, c(list( object = Distr, fun = pr.fct, L2 = L2deriv,
+ pr.sign = -1), dotsI))
a <- -b * p.p/(p.p+m.p)
Deleted: pkg/ROptEst/R/RMXEOMSEMBREOBRE.R
===================================================================
--- pkg/ROptEst/R/RMXEOMSEMBREOBRE.R 2019-03-02 16:05:00 UTC (rev 1184)
+++ pkg/ROptEst/R/RMXEOMSEMBREOBRE.R 2019-03-02 16:06:02 UTC (rev 1185)
@@ -1,177 +0,0 @@
-RMXEstimator <- function(x, L2Fam, fsCor = 1, initial.est,
- neighbor = ContNeighborhood(), steps = 1L,
- distance = CvMDist, startPar = NULL, verbose = NULL,
- OptOrIter = "iterate",
- useLast = getRobAStBaseOption("kStepUseLast"),
- withUpdateInKer = getRobAStBaseOption("withUpdateInKer"),
- IC.UpdateInKer = getRobAStBaseOption("IC.UpdateInKer"),
- withICList = getRobAStBaseOption("withICList"),
- withPICList = getRobAStBaseOption("withPICList"),
- na.rm = TRUE, initial.est.ArgList, ..., withLogScale = TRUE,
- ..withCheck=FALSE, withTimings = FALSE, withMDE = NULL,
- withEvalAsVar = NULL, withMakeIC = FALSE,
- modifyICwarn = NULL){
-
- mc <- match.call(expand.dots=FALSE)
- dots <- mc$"..."
-
- gsANY <- selectMethod("getStartIC", c(model="ANY",risk="ANY"))@defined
- clsL2Fam <- c(class(L2Fam))
- gsCUR <- selectMethod("getStartIC", c(model=clsL2Fam, risk="interpolRisk"))@defined
- risk0 <- asMSE()
- if(!all(all.equal(gsANY,gsCUR)==TRUE)) risk0 <- RMXRRisk()
-
- roptestArgList <- list(x = x, L2Fam = L2Fam, fsCor = fsCor,
- neighbor = neighbor, risk = risk0, steps = steps,
- distance = distance, startPar = startPar, verbose = verbose,
- OptOrIter = OptOrIter, useLast = useLast,
- withUpdateInKer = withUpdateInKer, IC.UpdateInKer = IC.UpdateInKer,
- withICList = withICList, withPICList = withPICList, na.rm = na.rm,
- withLogScale = withLogScale, ..withCheck = ..withCheck,
- withTimings = withTimings, withMDE = withMDE,
- withEvalAsVar = withEvalAsVar, withMakeIC = withMakeIC,
- modifyICwarn = modifyICwarn)
-
- if(!is.null(dots)) roptestArgList <- c(roptestArgList, dots)
- if(!missing(initial.est)) roptestArgList$initial.est <- initial.est
- if(!missing(initial.est.ArgList)) roptestArgList$initial.est.ArgList <- initial.est
-
- res <- do.call(roptest, roptestArgList)
- res at roptestCall <- quote(res at estimate.call)
- res at estimate.call <- mc
- return(res)
-}
-
-OMSEstimator <- function(x, L2Fam, eps =0.5, fsCor = 1, initial.est,
- neighbor = ContNeighborhood(), steps = 1L,
- distance = CvMDist, startPar = NULL, verbose = NULL,
- OptOrIter = "iterate",
- useLast = getRobAStBaseOption("kStepUseLast"),
- withUpdateInKer = getRobAStBaseOption("withUpdateInKer"),
- IC.UpdateInKer = getRobAStBaseOption("IC.UpdateInKer"),
- withICList = getRobAStBaseOption("withICList"),
- withPICList = getRobAStBaseOption("withPICList"),
- na.rm = TRUE, initial.est.ArgList, ..., withLogScale = TRUE,
- ..withCheck=FALSE, withTimings = FALSE, withMDE = NULL,
- withEvalAsVar = NULL, withMakeIC = FALSE,
- modifyICwarn = NULL){
-
- if(!is.numeric(eps)||length(eps)>1||any(eps<0))
- stop("Radius 'eps' must be given, of length 1 and non-negative.")
- mc <- match.call(expand.dots=FALSE)
- dots <- mc$"..."
-
- gsANY <- selectMethod("getStartIC", c(model="ANY",risk="ANY"))@defined
- clsL2Fam <- c(class(L2Fam))
- gsCUR <- selectMethod("getStartIC", c(model=clsL2Fam, risk="interpolRisk"))@defined
- risk0 <- asMSE()
- if(!all(all.equal(gsANY,gsCUR)==TRUE)&& abs(eps-0.5)<1e-3) risk0 <- OMSRRisk()
-
- roptestArgList <- list(x = x, L2Fam = L2Fam, eps = 0.5, fsCor = fsCor,
- neighbor = neighbor, risk = risk0, steps = steps,
- distance = distance, startPar = startPar, verbose = verbose,
- OptOrIter = OptOrIter, useLast = useLast,
- withUpdateInKer = withUpdateInKer, IC.UpdateInKer = IC.UpdateInKer,
- withICList = withICList, withPICList = withPICList, na.rm = na.rm,
- withLogScale = withLogScale, ..withCheck = ..withCheck,
- withTimings = withTimings, withMDE = withMDE,
- withEvalAsVar = withEvalAsVar, withMakeIC = withMakeIC,
- modifyICwarn = modifyICwarn)
-
- if(!is.null(dots)) roptestArgList <- c(roptestArgList, dots)
- if(!missing(initial.est)) roptestArgList$initial.est <- initial.est
- if(!missing(initial.est.ArgList)) roptestArgList$initial.est.ArgList <- initial.est
-
- res <- do.call(roptest, roptestArgList)
- res at roptestCall <- quote(res at estimate.call)
- res at estimate.call <- mc
- return(res)
-}
-
-OBREstimator <- function(x, L2Fam, eff=0.95, fsCor = 1, initial.est,
- neighbor = ContNeighborhood(), steps = 1L,
- distance = CvMDist, startPar = NULL, verbose = NULL,
- OptOrIter = "iterate",
- useLast = getRobAStBaseOption("kStepUseLast"),
- withUpdateInKer = getRobAStBaseOption("withUpdateInKer"),
- IC.UpdateInKer = getRobAStBaseOption("IC.UpdateInKer"),
- withICList = getRobAStBaseOption("withICList"),
- withPICList = getRobAStBaseOption("withPICList"),
- na.rm = TRUE, initial.est.ArgList, ..., withLogScale = TRUE,
- ..withCheck=FALSE, withTimings = FALSE, withMDE = NULL,
- withEvalAsVar = NULL, withMakeIC = FALSE,
- modifyICwarn = NULL){
-
- if(!is.numeric(eff)||length(eff)>1||any(eff<0|eff>1))
- stop("Efficiency loss (in the ideal model) 'eff' must be given, of length 1 and in [0,1].")
- mc <- match.call(expand.dots=FALSE)
- dots <- mc$"..."
-
- risk0 <- asAnscombe(eff)
-
- roptestArgList <- list(x = x, L2Fam = L2Fam, fsCor = fsCor,
- neighbor = neighbor, risk = risk0, steps = steps,
- distance = distance, startPar = startPar, verbose = verbose,
- OptOrIter = OptOrIter, useLast = useLast,
- withUpdateInKer = withUpdateInKer, IC.UpdateInKer = IC.UpdateInKer,
- withICList = withICList, withPICList = withPICList, na.rm = na.rm,
- withLogScale = withLogScale, ..withCheck = ..withCheck,
- withTimings = withTimings, withMDE = withMDE,
- withEvalAsVar = withEvalAsVar, withMakeIC = withMakeIC,
- modifyICwarn = modifyICwarn)
-
- if(!is.null(dots)) roptestArgList <- c(roptestArgList, dots)
- if(!missing(initial.est)) roptestArgList$initial.est <- initial.est
- if(!missing(initial.est.ArgList)) roptestArgList$initial.est.ArgList <- initial.est
-
- res <- do.call(roptest, roptestArgList)
- res at roptestCall <- quote(res at estimate.call)
- res at estimate.call <- mc
- return(res)
-}
-
-MBREstimator <- function(x, L2Fam, fsCor = 1, initial.est,
- neighbor = ContNeighborhood(), steps = 1L,
- distance = CvMDist, startPar = NULL, verbose = NULL,
- OptOrIter = "iterate",
- useLast = getRobAStBaseOption("kStepUseLast"),
- withUpdateInKer = getRobAStBaseOption("withUpdateInKer"),
- IC.UpdateInKer = getRobAStBaseOption("IC.UpdateInKer"),
- withICList = getRobAStBaseOption("withICList"),
- withPICList = getRobAStBaseOption("withPICList"),
- na.rm = TRUE, initial.est.ArgList, ..., withLogScale = TRUE,
- ..withCheck=FALSE, withTimings = FALSE, withMDE = NULL,
- withEvalAsVar = NULL, withMakeIC = FALSE,
- modifyICwarn = NULL){
-
- mc <- match.call(expand.dots=FALSE)
- dots <- mc$"..."
-
- gsANY <- selectMethod("getStartIC", c(model="ANY",risk="ANY"))@defined
- clsL2Fam <- c(class(L2Fam))
- gsCUR <- selectMethod("getStartIC", c(model=clsL2Fam, risk="interpolRisk"))@defined
- risk0 <- asBias()
- if(!all(all.equal(gsANY,gsCUR)==TRUE)) risk0 <- MBRRisk()
-
- roptestArgList <- list(x = x, L2Fam = L2Fam, fsCor = fsCor,
- neighbor = neighbor, risk = risk0, steps = steps,
- distance = distance, startPar = startPar, verbose = verbose,
- OptOrIter = OptOrIter, useLast = useLast,
- withUpdateInKer = withUpdateInKer, IC.UpdateInKer = IC.UpdateInKer,
- withICList = withICList, withPICList = withPICList, na.rm = na.rm,
- withLogScale = withLogScale, ..withCheck = ..withCheck,
- withTimings = withTimings, withMDE = withMDE,
- withEvalAsVar = withEvalAsVar, withMakeIC = withMakeIC,
- modifyICwarn = modifyICwarn)
-
- if(!is.null(dots)) roptestArgList <- c(roptestArgList, dots)
- if(!missing(initial.est)) roptestArgList$initial.est <- initial.est
- if(!missing(initial.est.ArgList)) roptestArgList$initial.est.ArgList <- initial.est
-
- res <- do.call(roptest, roptestArgList)
- res at roptestCall <- quote(res at estimate.call)
- res at estimate.call <- mc
- return(res)
-
-}
-
Copied: pkg/ROptEst/R/RMXEOMSEMBREOBRE.R (from rev 1178, branches/robast-1.2/pkg/ROptEst/R/RMXEOMSEMBREOBRE.R)
===================================================================
--- pkg/ROptEst/R/RMXEOMSEMBREOBRE.R (rev 0)
+++ pkg/ROptEst/R/RMXEOMSEMBREOBRE.R 2019-03-02 16:06:02 UTC (rev 1185)
@@ -0,0 +1,185 @@
+RMXEstimator <- function(x, L2Fam, fsCor = 1, initial.est,
+ neighbor = ContNeighborhood(), steps = 1L,
+ distance = CvMDist, startPar = NULL, verbose = NULL,
+ OptOrIter = "iterate",
+ useLast = getRobAStBaseOption("kStepUseLast"),
+ withUpdateInKer = getRobAStBaseOption("withUpdateInKer"),
+ IC.UpdateInKer = getRobAStBaseOption("IC.UpdateInKer"),
+ withICList = getRobAStBaseOption("withICList"),
+ withPICList = getRobAStBaseOption("withPICList"),
+ na.rm = TRUE, initial.est.ArgList, ..., withLogScale = TRUE,
+ ..withCheck=FALSE, withTimings = FALSE, withMDE = NULL,
+ withEvalAsVar = NULL, withMakeIC = FALSE,
+ modifyICwarn = NULL, E.argList = NULL,
+ diagnostic = FALSE){
+
+ mc <- match.call(expand.dots=FALSE)
+ dots <- mc$"..."
+
+ gsANY <- selectMethod("getStartIC", c(model="ANY",risk="ANY"))@defined
+ clsL2Fam <- c(class(L2Fam))
+ gsCUR <- selectMethod("getStartIC", c(model=clsL2Fam, risk="interpolRisk"))@defined
+ risk0 <- asMSE()
+ if(!all(all.equal(gsANY,gsCUR)==TRUE)) risk0 <- RMXRRisk()
+
+ roptestArgList <- list(x = x, L2Fam = L2Fam, fsCor = fsCor,
+ neighbor = neighbor, risk = risk0, steps = steps,
+ distance = distance, startPar = startPar, verbose = verbose,
+ OptOrIter = OptOrIter, useLast = useLast,
+ withUpdateInKer = withUpdateInKer, IC.UpdateInKer = IC.UpdateInKer,
+ withICList = withICList, withPICList = withPICList, na.rm = na.rm,
+ withLogScale = withLogScale, ..withCheck = ..withCheck,
+ withTimings = withTimings, withMDE = withMDE,
+ withEvalAsVar = withEvalAsVar, withMakeIC = withMakeIC,
+ modifyICwarn = modifyICwarn, E.argList = E.argList,
+ diagnostic = diagnostic)
+
+ if(!is.null(dots)) roptestArgList <- c(roptestArgList, dots)
+ if(!missing(initial.est)) roptestArgList$initial.est <- initial.est
+ if(!missing(initial.est.ArgList)) roptestArgList$initial.est.ArgList <- initial.est
+
+ res <- do.call(roptest, roptestArgList)
+ res at roptestCall <- res at estimate.call
+ res at estimate.call <- mc
+ return(res)
+}
+
+OMSEstimator <- function(x, L2Fam, eps =0.5, fsCor = 1, initial.est,
+ neighbor = ContNeighborhood(), steps = 1L,
+ distance = CvMDist, startPar = NULL, verbose = NULL,
+ OptOrIter = "iterate",
+ useLast = getRobAStBaseOption("kStepUseLast"),
+ withUpdateInKer = getRobAStBaseOption("withUpdateInKer"),
+ IC.UpdateInKer = getRobAStBaseOption("IC.UpdateInKer"),
+ withICList = getRobAStBaseOption("withICList"),
+ withPICList = getRobAStBaseOption("withPICList"),
+ na.rm = TRUE, initial.est.ArgList, ..., withLogScale = TRUE,
+ ..withCheck=FALSE, withTimings = FALSE, withMDE = NULL,
+ withEvalAsVar = NULL, withMakeIC = FALSE,
+ modifyICwarn = NULL, E.argList = NULL,
+ diagnostic = FALSE){
+
+ if(!is.numeric(eps)||length(eps)>1||any(eps<0))
+ stop("Radius 'eps' must be given, of length 1 and non-negative.")
+ mc <- match.call(expand.dots=FALSE)
+ dots <- mc$"..."
+
+ gsANY <- selectMethod("getStartIC", c(model="ANY",risk="ANY"))@defined
+ clsL2Fam <- c(class(L2Fam))
+ gsCUR <- selectMethod("getStartIC", c(model=clsL2Fam, risk="interpolRisk"))@defined
+ risk0 <- asMSE()
+ if(!all(all.equal(gsANY,gsCUR)==TRUE)&& abs(eps-0.5)<1e-3) risk0 <- OMSRRisk()
+
+ roptestArgList <- list(x = x, L2Fam = L2Fam, eps = 0.5, fsCor = fsCor,
+ neighbor = neighbor, risk = risk0, steps = steps,
+ distance = distance, startPar = startPar, verbose = verbose,
+ OptOrIter = OptOrIter, useLast = useLast,
+ withUpdateInKer = withUpdateInKer, IC.UpdateInKer = IC.UpdateInKer,
+ withICList = withICList, withPICList = withPICList, na.rm = na.rm,
+ withLogScale = withLogScale, ..withCheck = ..withCheck,
+ withTimings = withTimings, withMDE = withMDE,
+ withEvalAsVar = withEvalAsVar, withMakeIC = withMakeIC,
+ modifyICwarn = modifyICwarn, E.argList = E.argList,
+ diagnostic = diagnostic)
+
+ if(!is.null(dots)) roptestArgList <- c(roptestArgList, dots)
+ if(!missing(initial.est)) roptestArgList$initial.est <- initial.est
+ if(!missing(initial.est.ArgList)) roptestArgList$initial.est.ArgList <- initial.est
+
+ res <- do.call(roptest, roptestArgList)
+ res at roptestCall <- res at estimate.call
+ res at estimate.call <- mc
+ return(res)
+}
+
+OBREstimator <- function(x, L2Fam, eff=0.95, fsCor = 1, initial.est,
+ neighbor = ContNeighborhood(), steps = 1L,
+ distance = CvMDist, startPar = NULL, verbose = NULL,
+ OptOrIter = "iterate",
+ useLast = getRobAStBaseOption("kStepUseLast"),
+ withUpdateInKer = getRobAStBaseOption("withUpdateInKer"),
+ IC.UpdateInKer = getRobAStBaseOption("IC.UpdateInKer"),
+ withICList = getRobAStBaseOption("withICList"),
+ withPICList = getRobAStBaseOption("withPICList"),
+ na.rm = TRUE, initial.est.ArgList, ..., withLogScale = TRUE,
+ ..withCheck=FALSE, withTimings = FALSE, withMDE = NULL,
+ withEvalAsVar = NULL, withMakeIC = FALSE,
+ modifyICwarn = NULL, E.argList = NULL,
+ diagnostic = FALSE){
+
+ if(!is.numeric(eff)||length(eff)>1||any(eff<0|eff>1))
+ stop("Efficiency loss (in the ideal model) 'eff' must be given, of length 1 and in [0,1].")
+ mc <- match.call(expand.dots=FALSE)
+ dots <- mc$"..."
+
+ risk0 <- asAnscombe(eff)
+
+ roptestArgList <- list(x = x, L2Fam = L2Fam, fsCor = fsCor,
+ neighbor = neighbor, risk = risk0, steps = steps,
+ distance = distance, startPar = startPar, verbose = verbose,
+ OptOrIter = OptOrIter, useLast = useLast,
+ withUpdateInKer = withUpdateInKer, IC.UpdateInKer = IC.UpdateInKer,
+ withICList = withICList, withPICList = withPICList, na.rm = na.rm,
+ withLogScale = withLogScale, ..withCheck = ..withCheck,
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/robast -r 1185
More information about the Robast-commits
mailing list