[Robast-commits] r1080 - branches/robast-1.1/pkg/ROptEst branches/robast-1.1/pkg/ROptEst/R branches/robast-1.1/pkg/ROptEst/inst branches/robast-1.1/pkg/ROptEst/man branches/robast-1.2/pkg/ROptEst branches/robast-1.2/pkg/ROptEst/R branches/robast-1.2/pkg/ROptEst/inst branches/robast-1.2/pkg/ROptEst/man pkg/ROptEst pkg/ROptEst/R pkg/ROptEst/inst pkg/ROptEst/man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Aug 1 03:09:12 CEST 2018
Author: ruckdeschel
Date: 2018-08-01 03:09:11 +0200 (Wed, 01 Aug 2018)
New Revision: 1080
Added:
branches/robast-1.1/pkg/ROptEst/R/RMXEOMSEMBREOBRE.R
branches/robast-1.1/pkg/ROptEst/man/ORobEstimate-class.Rd
branches/robast-1.1/pkg/ROptEst/man/RMXEOMSEMBREOBRE.Rd
branches/robast-1.2/pkg/ROptEst/R/RMXEOMSEMBREOBRE.R
branches/robast-1.2/pkg/ROptEst/R/getStartIClcsc.R
branches/robast-1.2/pkg/ROptEst/man/ORobEstimate-class.Rd
branches/robast-1.2/pkg/ROptEst/man/RMXEOMSEMBREOBRE.Rd
pkg/ROptEst/R/RMXEOMSEMBREOBRE.R
pkg/ROptEst/man/ORobEstimate-class.Rd
pkg/ROptEst/man/RMXEOMSEMBREOBRE.Rd
Modified:
branches/robast-1.1/pkg/ROptEst/NAMESPACE
branches/robast-1.1/pkg/ROptEst/R/AllClass.R
branches/robast-1.1/pkg/ROptEst/R/AllGeneric.R
branches/robast-1.1/pkg/ROptEst/R/getInfLM.R
branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asAnscombe.R
branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asGRisk.R
branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asHampel.R
branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asUnOvShoot.R
branches/robast-1.1/pkg/ROptEst/R/getModifyIC.R
branches/robast-1.1/pkg/ROptEst/R/getStartIC.R
branches/robast-1.1/pkg/ROptEst/R/internal.roptest.R
branches/robast-1.1/pkg/ROptEst/R/optIC.R
branches/robast-1.1/pkg/ROptEst/R/radiusMinimaxIC.R
branches/robast-1.1/pkg/ROptEst/R/roptest.new.R
branches/robast-1.1/pkg/ROptEst/inst/NEWS
branches/robast-1.1/pkg/ROptEst/man/getInfRobIC.Rd
branches/robast-1.1/pkg/ROptEst/man/getModifyIC.Rd
branches/robast-1.1/pkg/ROptEst/man/getStartIC-methods.Rd
branches/robast-1.1/pkg/ROptEst/man/inputGenerator.Rd
branches/robast-1.1/pkg/ROptEst/man/optIC.Rd
branches/robast-1.1/pkg/ROptEst/man/radiusMinimaxIC.Rd
branches/robast-1.1/pkg/ROptEst/man/robest.Rd
branches/robast-1.1/pkg/ROptEst/man/roptest.Rd
branches/robast-1.2/pkg/ROptEst/NAMESPACE
branches/robast-1.2/pkg/ROptEst/R/AllClass.R
branches/robast-1.2/pkg/ROptEst/R/AllGeneric.R
branches/robast-1.2/pkg/ROptEst/R/getInfLM.R
branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asAnscombe.R
branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asGRisk.R
branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asHampel.R
branches/robast-1.2/pkg/ROptEst/R/getInfRobIC_asUnOvShoot.R
branches/robast-1.2/pkg/ROptEst/R/getModifyIC.R
branches/robast-1.2/pkg/ROptEst/R/getStartIC.R
branches/robast-1.2/pkg/ROptEst/R/internal.roptest.R
branches/robast-1.2/pkg/ROptEst/R/optIC.R
branches/robast-1.2/pkg/ROptEst/R/radiusMinimaxIC.R
branches/robast-1.2/pkg/ROptEst/R/roptest.new.R
branches/robast-1.2/pkg/ROptEst/inst/NEWS
branches/robast-1.2/pkg/ROptEst/man/getInfRobIC.Rd
branches/robast-1.2/pkg/ROptEst/man/getModifyIC.Rd
branches/robast-1.2/pkg/ROptEst/man/getStartIC-methods.Rd
branches/robast-1.2/pkg/ROptEst/man/inputGenerator.Rd
branches/robast-1.2/pkg/ROptEst/man/optIC.Rd
branches/robast-1.2/pkg/ROptEst/man/radiusMinimaxIC.Rd
branches/robast-1.2/pkg/ROptEst/man/robest.Rd
branches/robast-1.2/pkg/ROptEst/man/roptest.Rd
pkg/ROptEst/NAMESPACE
pkg/ROptEst/R/AllClass.R
pkg/ROptEst/R/AllGeneric.R
pkg/ROptEst/R/getInfLM.R
pkg/ROptEst/R/getInfRobIC_asAnscombe.R
pkg/ROptEst/R/getInfRobIC_asGRisk.R
pkg/ROptEst/R/getInfRobIC_asHampel.R
pkg/ROptEst/R/getInfRobIC_asUnOvShoot.R
pkg/ROptEst/R/getModifyIC.R
pkg/ROptEst/R/getStartIC.R
pkg/ROptEst/R/internal.roptest.R
pkg/ROptEst/R/optIC.R
pkg/ROptEst/R/radiusMinimaxIC.R
pkg/ROptEst/R/roptest.new.R
pkg/ROptEst/inst/NEWS
pkg/ROptEst/man/getInfRobIC.Rd
pkg/ROptEst/man/getModifyIC.Rd
pkg/ROptEst/man/getStartIC-methods.Rd
pkg/ROptEst/man/inputGenerator.Rd
pkg/ROptEst/man/optIC.Rd
pkg/ROptEst/man/radiusMinimaxIC.Rd
pkg/ROptEst/man/robest.Rd
pkg/ROptEst/man/roptest.Rd
Log:
[ROptEst] trunk & branch 1.1 & branch 1.2
+ new wrapper functions RMXEstimator, OBREstimator, MBREstimator, OMSEstimator
+ new return class ORobEstimate for optimally robust estimators
+ try to minimize interim output while using roptest- and friends
Modified: branches/robast-1.1/pkg/ROptEst/NAMESPACE
===================================================================
--- branches/robast-1.1/pkg/ROptEst/NAMESPACE 2018-07-31 20:53:06 UTC (rev 1079)
+++ branches/robast-1.1/pkg/ROptEst/NAMESPACE 2018-08-01 01:09:11 UTC (rev 1080)
@@ -38,13 +38,14 @@
"getModifyIC")
exportMethods("updateNorm", "scaleUpdateIC", "eff",
"get.asGRisk.fct", "getStartIC", "plot",
- "comparePlot", "getRiskFctBV")
+ "comparePlot", "getRiskFctBV", "roptestCall")
export("getL2normL2deriv",
"asAnscombe", "asL1", "asL4",
"getReq", "getMaxIneff", "getRadius")
export("roptest","roptest.old", "robest",
+ "OBREstimator", "RMXEstimator", "MBREstimator", "OMSEstimator",
"getLagrangeMultByOptim","getLagrangeMultByIter")
-export("genkStepCtrl", "genstartCtrl", "gennbCtrl")
+export("genkStepCtrl", "genstartCtrl", "genstartICCtrl", "gennbCtrl")
export("cniperCont", "cniperPoint", "cniperPointPlot")
export(".generateInterpGrid",".getLMGrid",".saveGridToCSV", ".readGridFromCSV")
export(".RMXE.th",".OMSE.th", ".MBRE.th")
Modified: branches/robast-1.1/pkg/ROptEst/R/AllClass.R
===================================================================
--- branches/robast-1.1/pkg/ROptEst/R/AllClass.R 2018-07-31 20:53:06 UTC (rev 1079)
+++ branches/robast-1.1/pkg/ROptEst/R/AllClass.R 2018-08-01 01:09:11 UTC (rev 1080)
@@ -26,3 +26,33 @@
## asymptotic L1 error
setClass("asL1", contains = "asGRisk",
prototype = prototype(type = "asymptotic mean absolute error"))
+
+setClass("ORobEstimate",
+ representation(roptestCall = "OptionalCall"),
+ prototype(name = "Optimally robust asymptotically linear estimate",
+ estimate = numeric(0),
+ samplesize = numeric(0),
+ completecases = logical(0),
+ estimate.call = call("{}"),
+ steps = integer(0),
+ asvar = NULL,
+ asbias = NULL,
+ pIC = NULL,
+ pICList = NULL,
+ ICList = NULL,
+ ksteps = NULL,
+ uksteps = NULL,
+ start = matrix(0),
+ startval = matrix(0),
+ ustartval = matrix(0),
+ nuis.idx = NULL,
+ trafo = list(fct = function(x){
+ list(fval = x, mat = matrix(1))},
+ mat = matrix(1)), ### necessary for comparison with unit matrix
+ Infos = matrix(c(character(0),character(0)), ncol=2,
+ dimnames=list(character(0), c("method", "message"))),
+ untransformed.estimate = NULL,
+ untransformed.asvar = NULL,
+ robestCall = NULL,
+ roptestCall = NULL),
+ contains = "kStepEstimate")
Modified: branches/robast-1.1/pkg/ROptEst/R/AllGeneric.R
===================================================================
--- branches/robast-1.1/pkg/ROptEst/R/AllGeneric.R 2018-07-31 20:53:06 UTC (rev 1079)
+++ branches/robast-1.1/pkg/ROptEst/R/AllGeneric.R 2018-08-01 01:09:11 UTC (rev 1080)
@@ -90,3 +90,6 @@
if(!isGeneric("getStartIC")){
setGeneric("getStartIC", function(model, risk, ...) standardGeneric("getStartIC"))
}
+if(!isGeneric("roptestCall")){
+ setGeneric("roptestCall", function(object) standardGeneric("roptestCall"))
+}
Added: branches/robast-1.1/pkg/ROptEst/R/RMXEOMSEMBREOBRE.R
===================================================================
--- branches/robast-1.1/pkg/ROptEst/R/RMXEOMSEMBREOBRE.R (rev 0)
+++ branches/robast-1.1/pkg/ROptEst/R/RMXEOMSEMBREOBRE.R 2018-08-01 01:09:11 UTC (rev 1080)
@@ -0,0 +1,177 @@
+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)
+
+}
+
Modified: branches/robast-1.1/pkg/ROptEst/R/getInfLM.R
===================================================================
--- branches/robast-1.1/pkg/ROptEst/R/getInfLM.R 2018-07-31 20:53:06 UTC (rev 1079)
+++ branches/robast-1.1/pkg/ROptEst/R/getInfLM.R 2018-08-01 01:09:11 UTC (rev 1080)
@@ -9,6 +9,7 @@
verbose = NULL, warnit = TRUE){
if(missing(verbose)|| is.null(verbose))
verbose <- getRobAStBaseOption("all.verbose")
+ if(missing(warnit)|| is.null(warnit)) warnit <- TRUE
LMcall <- match.call()
## initialization
Modified: branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asAnscombe.R
===================================================================
--- branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asAnscombe.R 2018-07-31 20:53:06 UTC (rev 1079)
+++ branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asAnscombe.R 2018-08-01 01:09:11 UTC (rev 1080)
@@ -8,6 +8,8 @@
upper = NULL, lower = NULL, maxiter, tol, warn, noLow = FALSE,
verbose = NULL, checkBounds = TRUE, ...){
+ if(missing(warn)|| is.null(warn)) warn <- FALSE
+
if(missing(verbose)|| is.null(verbose))
verbose <- getRobAStBaseOption("all.verbose")
@@ -55,7 +57,7 @@
normtype = normtype(risk))
upBerg <- getInfRobIC(L2deriv, risk.b, neighbor, symm, Finfo, trafo,
upper = 3*upper, lower = lower, maxiter = maxi,
- tol = toli, warn, noLow = noLow,
+ tol = toli, warn = warn, noLow = noLow,
verbose = FALSE, checkBounds = FALSE)
trV <- upBerg$risk$trAsCov$value
if(!is.na(trV)) e.up <- FI/trV
@@ -72,7 +74,8 @@
toli <- min(tol*100^(1/it.erg),1e-3)
checkBounds <- checkBounds & it.erg>10
erg <<- getInfRobIC(L2deriv, risk.b, neighbor, symm, Finfo, trafo,
- upper = upper, lower = lower, maxiter = maxi, tol = toli, warn, noLow = noLow,
+ upper = upper, lower = lower, maxiter = maxi, tol = toli,
+ warn = warn, noLow = noLow,
verbose = verbose, checkBounds = checkBounds)
trV <- erg$risk$trAsCov$value
if(verbose) cat("Outer iteration:", it.erg," b_0=", round(b0,3),
@@ -87,7 +90,7 @@
b <- uniroot(funb, interval=c(lower,upper), f.lower=f.low,
f.upper=e.up-eff,tol=tol,maxiter=maxiter)
erg$info <- c(erg$info,
- paste("optimally bias-robust IC for ARE", eff, " in the ideal model"))
+ paste("optimally bias-robust IC for ARE", eff, " in the ideal model" ,collapse="", sep=" "))
erg$risk$eff <- b$f.root+eff
return(erg)
@@ -167,7 +170,7 @@
L2derivDistrSymm, Finfo, trafo, onesetLM = onesetLM,
z.start, A.start, upper = upper, lower = lower,
OptOrIter = OptOrIter, maxiter=maxi,
- tol=toli, warn,
+ tol=toli, warn = warn,
verbose = FALSE, checkBounds = FALSE, ...)
trV <- lowBerg$risk$trAsCov$value
f.low <- trV.ML/trV -eff
@@ -189,7 +192,7 @@
L2derivDistrSymm, Finfo, trafo, onesetLM = onesetLM,
z.start, A.start, upper = upper, lower = lower,
OptOrIter = OptOrIter, maxiter=maxi,
- tol=toli, warn,
+ tol=toli, warn = warn,
verbose = FALSE, checkBounds = FALSE, ...)
trV <- upBerg$risk$trAsCov$value
e.up <- trV.ML/trV
@@ -213,18 +216,19 @@
Distr, DistrSymm, L2derivSymm,
L2derivDistrSymm, Finfo, trafo, onesetLM = onesetLM,
z.start, A.start, upper = upper, lower = lower,
- OptOrIter = OptOrIter, maxiter = maxi, tol = toli , warn,
+ OptOrIter = OptOrIter, maxiter = maxi, tol = toli , warn = warn,
verbose = verbL, checkBounds = chkbd, ...)
trV <- erg$risk$trAsCov$value
if(verbose) cat("Outer iteration:", it.erg," b_0=", round(b0,3),
" eff=", round(trV.ML/trV,3), "\n")
return(trV.ML/trV-eff)
}
- print(c(lower,upper, f.lower=f.low, f.upper=e.up-eff))
+ if(verbose) print(c(lower,upper, f.lower=f.low, f.upper=e.up-eff))
b <- uniroot(funb, interval=c(lower,upper), f.lower=f.low,
f.upper=e.up-eff,tol=tol,maxiter=maxiter)
erg$info <- c(erg$info,
- paste("optimally bias-robust IC for ARE", eff, " in the ideal model"))
+ paste("optimally bias-robust IC for ARE", eff, " in the ideal model",
+ collapse="", sep=" "))
erg$risk$eff <- b$f.root+eff
erg$call <- mc
Modified: branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asGRisk.R
===================================================================
--- branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asGRisk.R 2018-07-31 20:53:06 UTC (rev 1079)
+++ branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asGRisk.R 2018-08-01 01:09:11 UTC (rev 1080)
@@ -11,6 +11,8 @@
if(missing(verbose)|| is.null(verbose))
verbose <- getRobAStBaseOption("all.verbose")
+ if(missing(warn)|| is.null(warn)) warn <- FALSE
+
biastype <- biastype(risk)
normtype <- normtype(risk)
radius <- neighbor at radius
@@ -133,13 +135,13 @@
if(abs(prec.old - prec) < 1e-10){
if(iter>1)
problem <- TRUE
- cat("algorithm did not converge!\n", "achieved precision:\t", prec, "\n")
+ if(warn) cat("algorithm did not converge!\n", "achieved precision:\t", prec, "\n")
break
}
if(iter > maxiter){
if(iter>1)
problem <- TRUE
- cat("maximum iterations reached!\n", "achieved precision:\t", prec, "\n")
+ if(warn) cat("maximum iterations reached!\n", "achieved precision:\t", prec, "\n")
break
}
}
@@ -375,7 +377,7 @@
a.start = a, z.start = z, A.start = A, w.start = w,
std = std, z.comp = z.comp,
A.comp = A.comp, maxiter = maxit2, tol = tol,
- verbose = verbose, warnit = (OptOrIter!=2))
+ verbose = verbose, warnit = warn&(OptOrIter!=2))
## read out solution
w <- erg$w
@@ -405,12 +407,12 @@
if(prec < tol) break
if(abs(prec.old - prec) < 1e-10){
problem <- TRUE
- cat("algorithm did not converge!\n", "achieved precision:\t", prec, "\n")
+ if(warn) cat("algorithm did not converge!\n", "achieved precision:\t", prec, "\n")
break
}
if(iter > maxiter){
problem <- TRUE
- cat("maximum iterations reached!\n", "achieved precision:\t", prec, "\n")
+ if(warn) cat("maximum iterations reached!\n", "achieved precision:\t", prec, "\n")
break
}
}
Modified: branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asHampel.R
===================================================================
--- branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asHampel.R 2018-07-31 20:53:06 UTC (rev 1079)
+++ branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asHampel.R 2018-08-01 01:09:11 UTC (rev 1080)
@@ -10,6 +10,7 @@
if(missing(verbose)|| is.null(verbose))
verbose <- getRobAStBaseOption("all.verbose")
+ if(missing(warn)|| is.null(warn)) warn <- FALSE
biastype <- biastype(risk)
normtype <- normtype(risk)
@@ -20,7 +21,7 @@
if(checkBounds){
bmax <- abs(as.vector(A))*max(abs(q.l(L2deriv)(0)), q.l(L2deriv)(1))
if(b >= bmax){
- if(warn) cat("'b >= maximum asymptotic bias' => (classical) optimal IC\n",
+ if(warn) cat("'b >= maximum asymptotic bias' => (classical) optimal IC\n",
"in sense of Cramer-Rao bound is returned\n")
res <- getInfRobIC(L2deriv = L2deriv, risk = asCov(),
neighbor = neighbor, Finfo = Finfo, trafo = trafo,
@@ -43,7 +44,7 @@
trafo = trafo, maxiter = maxiter, tol = tol, Finfo = Finfo,
warn = warn, verbose = verbose)
bmin <- res$b
- cat("minimal bound:\t", bmin, "\n")
+ if(verbose)cat("minimal bound:\t", bmin, "\n")
}else{
bmin <- b/2
}
@@ -98,7 +99,7 @@
print(round(c(A=A,z=z),3))
}
if(iter > maxiter){
- cat("maximum iterations reached!\n", "achieved precision:\t",
+ if(verbose) cat("maximum iterations reached!\n", "achieved precision:\t",
max(abs(as.vector(A-A.old)), abs(z-z.old)), "\n")
break
}
@@ -153,6 +154,7 @@
if(missing(verbose)|| is.null(verbose))
verbose <- getRobAStBaseOption("all.verbose")
+ if(missing(warn)|| is.null(warn)) warn <- FALSE
mc <- match.call()
@@ -237,7 +239,7 @@
w.start = w,
std = std, z.comp = z.comp,
A.comp = A.comp, maxiter = maxiter, tol = tol,
- verbose = verbose)
+ warnit = warn, verbose = verbose)
}
## read out solution
@@ -331,6 +333,7 @@
L2derivDistrSymm, z.start, A.start, trafo, maxiter,
tol, QuadForm, verbose, nrvalpts, warn){
+ if(missing(warn)|| is.null(warn)) warn <- FALSE
ClassIC <- trafo %*% solve(Finfo) %*% L2deriv
lower.x <- getLow(Distr)
@@ -338,7 +341,7 @@
x <- seq(from = lower.x, to = upper.x, length = nrvalpts)
bmax <- sapply(x,function(x) evalRandVar(ClassIC,x))
bmax <- sqrt(max(colSums(as.matrix(bmax^2))))
- cat("numerical approximation of maximal bound:\t", bmax, "\n")
+ if (verbose) cat("numerical approximation of maximal bound:\t", bmax, "\n")
if(b >= bmax){
if(warn) cat("'b >= maximum asymptotic bias' => (classical) optimal IC\n",
@@ -368,7 +371,7 @@
verbose = verbose)
bmin <- res$b
- cat("minimal bound:\t", bmin, "\n")
+ if(verbose) cat("minimal bound:\t", bmin, "\n")
if(b <= bmin){
if(warn) cat("'b <= minimum asymptotic bias'\n",
"=> the minimum asymptotic bias (lower case) solution is returned\n")
Modified: branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asUnOvShoot.R
===================================================================
--- branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asUnOvShoot.R 2018-07-31 20:53:06 UTC (rev 1079)
+++ branches/robast-1.1/pkg/ROptEst/R/getInfRobIC_asUnOvShoot.R 2018-08-01 01:09:11 UTC (rev 1080)
@@ -5,7 +5,12 @@
risk = "asUnOvShoot",
neighbor = "UncondNeighborhood"),
function(L2deriv, risk, neighbor, symm, Finfo, trafo,
- upper, lower, maxiter, tol, warn, ...){
+ upper, lower, maxiter, tol, warn, verbose = NULL, ...){
+
+ if(missing(verbose)|| is.null(verbose))
+ verbose <- getRobAStBaseOption("all.verbose")
+ if(missing(warn)|| is.null(warn)) warn <- FALSE
+
biastype <- biastype(risk)
radius <- neighbor at radius
if(identical(all.equal(radius, 0), TRUE)){
@@ -115,7 +120,7 @@
if(S) break
if(max(abs(z - z.old), abs(c0-c0.old)) < tol) break
if(iter > maxiter){
- cat("maximum iterations reached!\n", "achieved precision:\t", abs(c0 - c0.old), "\n")
+ if(warn) cat("maximum iterations reached!\n", "achieved precision:\t", abs(c0 - c0.old), "\n")
break
}
}
Modified: branches/robast-1.1/pkg/ROptEst/R/getModifyIC.R
===================================================================
--- branches/robast-1.1/pkg/ROptEst/R/getModifyIC.R 2018-07-31 20:53:06 UTC (rev 1079)
+++ branches/robast-1.1/pkg/ROptEst/R/getModifyIC.R 2018-08-01 01:09:11 UTC (rev 1080)
@@ -5,14 +5,18 @@
setMethod("getModifyIC", signature(L2FamIC = "L2ParamFamily",
neighbor = "Neighborhood", risk = "asRisk"),
function(L2FamIC, neighbor, risk, ...){
- dots <- match.call(call = sys.call(sys.parent(1)), expand.dots=FALSE)[["..."]]
+ mc <- match.call(call = sys.call(sys.parent(1)), expand.dots=FALSE)
+ mcl <- as.list(mc)[-1]
+ dots <- mcl[["..."]]
dots$verbose <- NULL
+ dots$warn <- FALSE
modIC <- function(L2Fam, IC){}
body(modIC) <- substitute({ verbose <- getRobAStBaseOption("all.verbose")
infMod <- InfRobModel(L2Fam, nghb)
do.call(optIC, args = c(list(infMod, risk=R),
dots0)) },
- list(nghb = neighbor, R = risk, dots0 = dots))
+ list(nghb = neighbor, R = risk,
+ dots0 = eval(dots, envir=parent.frame(2))))
return(modIC)
})
@@ -104,7 +108,9 @@
setMethod("getModifyIC", signature(L2FamIC = "L2ScaleFamily",
neighbor = "UncondNeighborhood", risk = "asGRisk"),
- function(L2FamIC, neighbor, risk, ...){
+ function(L2FamIC, neighbor, risk, ..., modifyICwarn = NULL){
+ if(missing(modifyICwarn)|| is.null(modifyICwarn))
+ modifyICwarn <- getRobAStBaseOption("modifyICwarn")
modIC <- function(L2Fam, IC){
ICL2Fam <- eval(CallL2Fam(IC))
if(is(L2Fam, "L2ScaleFamily") && is(distribution(L2Fam), class(distribution(ICL2Fam)))){
@@ -112,8 +118,10 @@
sdalt = main(ICL2Fam),
IC = IC, neighbor = neighbor)
IC <- generateIC(neighbor = neighbor, L2Fam = L2Fam, res = res)
- addInfo(IC) <- c("modifyIC", "The IC has been modified")
- addInfo(IC) <- c("modifyIC", "The entries in 'Infos' may be wrong")
+ if(!any(grepl("Some entries in 'Infos' may be wrong", Infos(IC)[,2])) && modifyICwarn){
+ addInfo(IC) <- c("modifyIC", "The IC has been modified")
+ addInfo(IC) <- c("modifyIC", "Some entries in 'Infos' may be wrong")
+ }
return(IC)
}else{
makeIC(IC, L2Fam)
@@ -124,7 +132,10 @@
setMethod("getModifyIC", signature(L2FamIC = "L2LocationScaleFamily",
neighbor = "UncondNeighborhood", risk = "asGRisk"),
- function(L2FamIC, neighbor, risk, ...){
+ function(L2FamIC, neighbor, risk, ..., modifyICwarn = NULL){
+ if(missing(modifyICwarn)|| is.null(modifyICwarn))
+ modifyICwarn <- getRobAStBaseOption("modifyICwarn")
+
modIC <- function(L2Fam, IC){
ICL2Fam <- eval(CallL2Fam(IC))
if(is(L2Fam, "L2LocationScaleFamily") && is(distribution(L2Fam),
@@ -143,8 +154,10 @@
IC = IC, neighbor = neighbor)
IC <- generateIC(neighbor = neighbor, L2Fam = L2Fam, res = res)
- addInfo(IC) <- c("modifyIC", "The IC has been modified")
- addInfo(IC) <- c("modifyIC", "The entries in 'Infos' may be wrong")
+ if(!any(grepl("Some entries in 'Infos' may be wrong", Infos(IC)[,2])) && modifyICwarn){
+ addInfo(IC) <- c("modifyIC", "The IC has been modified")
+ addInfo(IC) <- c("modifyIC", "Some entries in 'Infos' may be wrong")
+ }
return(IC)
}else{
makeIC(IC, L2Fam)
Modified: branches/robast-1.1/pkg/ROptEst/R/getStartIC.R
===================================================================
--- branches/robast-1.1/pkg/ROptEst/R/getStartIC.R 2018-07-31 20:53:06 UTC (rev 1079)
+++ branches/robast-1.1/pkg/ROptEst/R/getStartIC.R 2018-08-01 01:09:11 UTC (rev 1080)
@@ -3,10 +3,9 @@
setMethod("getStartIC",signature(model = "L2ParamFamily", risk = "asGRisk"),
function(model, risk, ..., withEvalAsVar = TRUE, withMakeIC = FALSE,
- ..debug=FALSE){
+ ..debug=FALSE, modifyICwarn = NULL){
mc <- match.call(expand.dots=FALSE, call = sys.call(sys.parent(1)))
dots <- as.list(mc$"...")
-# cat("HALLLO IN getstartIC\n"); print(..debug)
if(missing(..debug)||!is.logical(..debug)) ..debug <- FALSE
if("fsCor" %in% names(dots)){
fsCor <- eval(dots[["fsCor"]])
@@ -21,23 +20,19 @@
dots$neighbor <- NULL
}else neighbor <- ContNeighborhood()
- sm.rmx <- selectMethod("radiusMinimaxIC", signature(
+
+ if(is.null(eps[["e"]])){
+ sm.rmx <- selectMethod("radiusMinimaxIC", signature(
class(model),class(neighbor),class(risk)))
- dots.rmx <- .fix.in.defaults(dots, sm.rmx)
- dots.rmx$L2Fam <- NULL
- dots.rmx$neighbor <- NULL
- dots.rmx$risk <- NULL
+ dots.rmx <- .fix.in.defaults(dots, sm.rmx)
+ dots.rmx$L2Fam <- NULL
+ dots.rmx$neighbor <- NULL
+ dots.rmx$risk <- NULL
+ dots.rmx$modifyICwarn <- modifyICwarn
+ dots.rmx[["warn"]] <- FALSE
+ if(!is.null(dots[["warn"]]))if(eval(dots[["warn"]])) dots.rmx[["warn"]] <- TRUE
- infMod <- InfRobModel(center = model, neighbor = neighbor)
- sm.optic <- selectMethod("optIC", signature(
- class(infMod),class(risk)))
- dots.optic <- .fix.in.defaults(dots, sm.optic)
- dots.optic$model <- NULL
- dots.optic$risk <- NULL
- dots.optic$.withEvalAsVar <- withEvalAsVar
- dots.optic$withMakeIC <- withMakeIC
-
- if(is.null(eps[["e"]])){
+ infMod <- InfRobModel(center = model, neighbor = neighbor)
dots.rmx$loRad <- eps$sqn * eps$lower
dots.rmx$upRad <- eps$sqn * eps$upper
arg.rmx <- c(list(L2Fam = model, neighbor = neighbor,
@@ -54,6 +49,17 @@
}else{
neighbor at radius <- eps$sqn * fsCor * eps$e
infMod <- InfRobModel(center = model, neighbor = neighbor)
+ sm.optic <- selectMethod("optIC", signature(
+ class(infMod),class(risk)))
+ dots.optic <- .fix.in.defaults(dots, sm.optic)
+ dots.optic$model <- NULL
+ dots.optic$risk <- NULL
+ dots.optic$.withEvalAsVar <- withEvalAsVar
+ dots.optic$withMakeIC <- withMakeIC
+ dots.optic$modifyICwarn <- modifyICwarn
+ dots.optic[["warn"]] <- FALSE
+ if(!is.null(dots[["warn"]]))if(eval(dots[["warn"]])) dots.optic[["warn"]] <- TRUE
+
arg.optic <- c(list(model = infMod, risk = risk),
dots.optic)
if(..debug) print(c(arg.optic=arg.optic))
@@ -71,16 +77,49 @@
)
setMethod("getStartIC",signature(model = "L2ParamFamily", risk = "asBias"),
- function(model, risk, ..., withMakeIC = FALSE, ..debug=FALSE){
+ function(model, risk, ..., withMakeIC = FALSE, ..debug=FALSE,
+ modifyICwarn = NULL){
mc <- match.call(expand.dots=FALSE, call = sys.call(sys.parent(1)))
dots <- as.list(mc$"...")
+
if("neighbor" %in% names(dots)){
neighbor <- eval(dots[["neighbor"]])
dots$neighbor <- NULL
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/robast -r 1080
More information about the Robast-commits
mailing list