[Robast-commits] r482 - branches/robast-0.9/pkg/RobExtremesBuffer
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed May 23 02:29:21 CEST 2012
Author: ruckdeschel
Date: 2012-05-23 02:29:21 +0200 (Wed, 23 May 2012)
New Revision: 482
Added:
branches/robast-0.9/pkg/RobExtremesBuffer/AllGeneric.R
branches/robast-0.9/pkg/RobExtremesBuffer/getStartIC.R
branches/robast-0.9/pkg/RobExtremesBuffer/internal-getpsi.R
branches/robast-0.9/pkg/RobExtremesBuffer/internal.roptest.R
branches/robast-0.9/pkg/RobExtremesBuffer/roptest.new.R
Removed:
branches/robast-0.9/pkg/RobExtremesBuffer/internal.roptest.R
branches/robast-0.9/pkg/RobExtremesBuffer/roptest.new.R
Log:
Spielwiese...
Added: branches/robast-0.9/pkg/RobExtremesBuffer/AllGeneric.R
===================================================================
--- branches/robast-0.9/pkg/RobExtremesBuffer/AllGeneric.R (rev 0)
+++ branches/robast-0.9/pkg/RobExtremesBuffer/AllGeneric.R 2012-05-23 00:29:21 UTC (rev 482)
@@ -0,0 +1,98 @@
+if(!isGeneric("getInfRobIC")){
+ setGeneric("getInfRobIC",
+ function(L2deriv, risk, neighbor, ...) standardGeneric("getInfRobIC"))
+}
+if(!isGeneric("getFixRobIC")){
+ setGeneric("getFixRobIC",
+ function(Distr, risk, neighbor, ...) standardGeneric("getFixRobIC"))
+}
+if(!isGeneric("getAsRisk")){
+ setGeneric("getAsRisk",
+ function(risk, L2deriv, neighbor, biastype, ...) standardGeneric("getAsRisk"))
+}
+if(!isGeneric("getFiRisk")){
+ setGeneric("getFiRisk",
+ function(risk, Distr, neighbor, ...) standardGeneric("getFiRisk"))
+}
+if(!isGeneric("getInfClip")){
+ setGeneric("getInfClip",
+ function(clip, L2deriv, risk, neighbor, ...) standardGeneric("getInfClip"))
+}
+if(!isGeneric("getFixClip")){
+ setGeneric("getFixClip",
+ function(clip, Distr, risk, neighbor, ...) standardGeneric("getFixClip"))
+}
+if(!isGeneric("getInfGamma")){
+ setGeneric("getInfGamma",
+ function(L2deriv, risk, neighbor, biastype, ...) standardGeneric("getInfGamma"))
+}
+if(!isGeneric("getInfCent")){
+ setGeneric("getInfCent",
+ function(L2deriv, neighbor, biastype, ...) standardGeneric("getInfCent"))
+}
+if(!isGeneric("getInfStand")){
+ setGeneric("getInfStand",
+ function(L2deriv, neighbor, biastype, ...) standardGeneric("getInfStand"))
+}
+if(!isGeneric("getInfV")){
+ setGeneric("getInfV",
+ function(L2deriv, neighbor, biastype, ...) standardGeneric("getInfV"))
+}
+if(!isGeneric("optIC")){
+ setGeneric("optIC", function(model, risk, ...) standardGeneric("optIC"))
+}
+if(!isGeneric("optRisk")){
+ setGeneric("optRisk", function(model, risk, ...) standardGeneric("optRisk"))
+}
+if(!isGeneric("radiusMinimaxIC")){
+ setGeneric("radiusMinimaxIC", function(L2Fam, neighbor, risk, ...)
+ standardGeneric("radiusMinimaxIC"))
+}
+if(!isGeneric("getIneffDiff")){
+ setGeneric("getIneffDiff", function(radius, L2Fam, neighbor, risk, ...)
+ standardGeneric("getIneffDiff"))
+}
+if(!isGeneric("leastFavorableRadius")){
+ setGeneric("leastFavorableRadius", function(L2Fam, neighbor, risk, ...)
+ standardGeneric("leastFavorableRadius"))
+}
+if(!isGeneric("lowerCaseRadius")){
+ setGeneric("lowerCaseRadius", function(L2Fam, neighbor, risk, biastype, ...)
+ standardGeneric("lowerCaseRadius"))
+}
+if(!isGeneric("minmaxBias")){
+ setGeneric("minmaxBias",
+ function(L2deriv, neighbor, biastype, ...) standardGeneric("minmaxBias"))
+}
+if(!isGeneric("getL1normL2deriv")){
+ setGeneric("getL1normL2deriv",
+ function(L2deriv, ...) standardGeneric("getL1normL2deriv"))
+}
+if(!isGeneric("updateNorm")){
+ setGeneric("updateNorm", function(normtype, ...) standardGeneric("updateNorm"))
+}
+if(!isGeneric("getModifyIC")){
+ setGeneric("getModifyIC", function(L2FamIC, neighbor, risk, ...) standardGeneric("getModifyIC"))
+}
+if(!isGeneric("scaleUpdateIC")){
+ setGeneric("scaleUpdateIC", function(neighbor, ...) standardGeneric("scaleUpdateIC"))
+}
+if(!isGeneric("cniperCont")){
+ setGeneric("cniperCont", function(IC1, IC2, L2Fam, neighbor, risk, ...) standardGeneric("cniperCont"))
+}
+if(!isGeneric("cniperPoint")){
+ setGeneric("cniperPoint", function(L2Fam, neighbor, risk, ...) standardGeneric("cniperPoint"))
+}
+if(!isGeneric("cniperPointPlot")){
+ setGeneric("cniperPointPlot", function(L2Fam, neighbor, risk, ...) standardGeneric("cniperPointPlot"))
+}
+if(!isGeneric("eff")){
+ setGeneric("eff", function(object) standardGeneric("eff"))
+}
+if(!isGeneric("get.asGRisk.fct")){
+ setGeneric("get.asGRisk.fct", function(Risk) standardGeneric("get.asGRisk.fct"))
+}
+
+if(!isGeneric("getStartIC")){
+ setGeneric("getStartIC", function(model, risk, ...) standardGeneric("getStartIC"))
+}
Added: branches/robast-0.9/pkg/RobExtremesBuffer/getStartIC.R
===================================================================
--- branches/robast-0.9/pkg/RobExtremesBuffer/getStartIC.R (rev 0)
+++ branches/robast-0.9/pkg/RobExtremesBuffer/getStartIC.R 2012-05-23 00:29:21 UTC (rev 482)
@@ -0,0 +1,58 @@
+setMethod("getStartIC",signature(model = "ANY", risk = "ANY"),
+ function(model, risk, ...) stop("not yet implemented"))
+
+setMethod("getStartIC",signature(model = "L2ParamFamily", risk = "asRisk"),
+ function(model, risk, ...){
+ mc <- match.call(expand=TRUE)
+ eps <- mc$eps
+ dots <- mc$dots
+
+ if(is.null(eps$e))){
+ r.lower <- eps$sqn * eps$lower
+ r.upper <- eps$sqn * eps$upper
+ ICstart <- do.call(radiusMinimaxIC,
+ c(list(L2Fam = mc$L2FamStart, neighbor = mc$neighbor,
+ risk = mc$risk,
+ loRad = r.lower, upRad = r.upper,
+ verbose = mc$verbose,
+ OptOrIter = mc$OptOrIter),dots))
+ if(!isTRUE(all.equal(mc$fsCor, 1, tol = 1e-3))){
+ neighbor at radius <- neighborRadius(ICstart)*mc$fsCor
+ infMod <- InfRobModel(center = mc$L2FamStart, neighbor = mc$neighbor)
+ ICstart <- do.call(optIC, c(list( model = mc$infMod, risk = mc$risk,
+ verbose = mc$verbose, OptOrIter = mc$OptOrIter),
+ dots))
+ }
+ }else{
+ neighbor at radius <- eps$sqn*eps$e*mc$fsCor
+ infMod <- InfRobModel(center = mc$L2FamStart, neighbor = mc$neighbor)
+ ICstart <- do.call(optIC, c(list(model = mc$infMod, risk = mc$risk,
+ verbose = mc$verbose, OptOrIter = mc$OptOrIter),
+ dots))
+ }
+ return(ICstart)
+ })
+
+
+
+setMethod("getStartIC",signature(model = "L2ScaleShapeUnion", risk = "interpolRisk"),
+ function(model, risk, ...){
+
+ mc <- match.call(expand=TRUE)
+
+ gridn <- type(risk)
+ nam <- name(model)
+ xi <- main(param(model))[scaleshapename(model)["scale"]]
+ nsng <- character(0)
+ sng <- try(getFromNamespace(gridn, ns = "ROptEst"),silent=TRUE)
+ if(!is(sng,"try-error")) nsng <- names(sng)
+ if(length(nsng)){
+ if(nam %in% nsng){
+ interpolfct <- sng[[nam]]$fct
+ return(.getPsi(xi, interpolfct, L2Fam, type(risk)))
+ }
+ }
+ mc$risk <- if(type(risk)==".MBRE") asMSE(r=0.5) else asBias()
+ return(do.call(getStartIC, mc[-1]))
+ })
+
Added: branches/robast-0.9/pkg/RobExtremesBuffer/internal-getpsi.R
===================================================================
--- branches/robast-0.9/pkg/RobExtremesBuffer/internal-getpsi.R (rev 0)
+++ branches/robast-0.9/pkg/RobExtremesBuffer/internal-getpsi.R 2012-05-23 00:29:21 UTC (rev 482)
@@ -0,0 +1,41 @@
+.getpsi <- function(xi, fct, L2Fam , type){
+
+ L2deriv <- L2deriv(L2Fam)
+ b <- fct(xi,1)
+ a <- c(fct(xi,2),fct(xi,3))
+ aw <- c(fct(xi,4),fct(xi,5))
+ am <- mean(c(fct(xi,7),fct(xi,8)))
+ A <- matrix(c(fct(xi,6),am,am,fct(xi,9)),2,2)}
+ am <- mean(c(fct(xi,11),fct(xi,12)))
+ Aw <- matrix(c(fct(xi,10),am,am,fct(xi,13)),2,2)
+
+ normt <- NormType()
+ biast <- symmetricBias()
+ ICT <- paste("optimally robust IC for", switch(type,
+ c(".OMSE"="maxMSE",".RMXE"="RMX", ".MBRE"="maxBias")))
+ riskT <- if(nameInSysdata!=".MBRE") "asGRisk" else "asBias"
+
+ w <- new("HampelWeight")
+ stand(w) <- Aw(xi0)
+ cent(w) <- aw(xi0)
+ clip(w) <- b(xi0)
+ if(type!=".MBRE")
+ weight(w) <- getweight(w, neighbor = neighbor, biastype = biast,
+ normW = normt)
+ else weight(w) <- minbiasweight(w, neighbor = neighbor, biastype = biast,
+ normW = normt)
+
+ res <- list(a = a(xi0), A = A(xi0), b = b(xi0), d = 0,
+ normtype = normt, biastype = biast, w = w,
+ info = c("optIC", ICT), risk = riskT,
+ modifyIC = function(L2Fam, IC){
+ para <- param(L2Fam)
+ xi0 <- main(para)[scaleshapename(L2Fam)["scale"]]
+ L2deriv0 <- EuclRandVarList(RealRandVariable(
+ L2Fam at L2deriv.fct(para),
+ Domain = Reals()))
+ .getpsi(xi0,fct, L2deriv0, type)
+ }
+ )
+ return(generateIC(ContNeighborhood(r=0.5), L2Fam, res))
+}
Deleted: branches/robast-0.9/pkg/RobExtremesBuffer/internal.roptest.R
===================================================================
--- branches/robast-0.9/pkg/RobExtremesBuffer/internal.roptest.R 2012-05-23 00:17:44 UTC (rev 481)
+++ branches/robast-0.9/pkg/RobExtremesBuffer/internal.roptest.R 2012-05-23 00:29:21 UTC (rev 482)
@@ -1,145 +0,0 @@
-.fix.in.defaults <- function(call.list, fun){
- formals.fun <- formals(fun)
- k <- length(call.list)
- L <- length(formals.fun)
- if("..." %in% names(formals.fun)) L <- L-1
- for(i in 1:L){
- if(!is(formals.fun[[i]],"name")){
- if(!names(formals.fun)[i] %in% names(call.list)&&!is.null(formals.fun[[i]])){
- k <- k + 1
- call.list[[k]] <- formals.fun[[i]]
- names(call.list)[k] <- names(formals.fun)[i]
- }
- }
- }
- return(call.list)
-
-}
-
-.pretreat <- function(x, na.rm = TRUE){
- if(missing(x))
- stop("'x' is missing with no default")
- if(!is.numeric(x)){
- if(is.data.frame(x))
- x <- data.matrix(x)
- else
- x <- as.matrix(x)
- if(!is.matrix(x))
- stop("'x' has to be a numeric vector resp. a matrix or data.frame")
- }
- completecases <- complete.cases(x)
- if(na.rm) x <- na.omit(x)
-}
-.check.eps <- function(...){
- mc <- match.call(expand=TRUE)
-
- eps <- eps.lower <- eps.upper <- NULL
- if(is.null(mc$eps) && is.null(mc$eps.lower) && is.null(mc$eps.upper)){
- eps.lower <- 0
- eps.upper <- 0.5
- }
- if(is.null(mc$eps)){
- if(!is.null(mc$eps.lower) && is.null(mc$eps.upper))
- eps.upper <- 0.5
- if(is.null(mc$eps.lower) && !is.null(mc$eps.upper))
- eps.lower <- 0
- if(length(eps.lower) != 1 || length(eps.upper) != 1)
- stop("'eps.lower' and 'eps.upper' have to be of length 1")
- if(!is.numeric(eps.lower) || !is.numeric(eps.upper) || eps.lower >= eps.upper)
- stop("'eps.lower' < 'eps.upper' is not fulfilled")
- if((eps.lower < 0) || (eps.upper > 0.5))
- stop("'eps.lower' and 'eps.upper' have to be in [0, 0.5]")
- }else{
- eps <- mc$eps
- if(length(eps) != 1)
- stop("'eps' has to be of length 1")
- if(eps == 0)
- stop("'eps = 0'! => use functions 'mean' and 'sd' for estimation")
- if((eps < 0) || (eps > 0.5))
- stop("'eps' has to be in (0, 0.5]")
- }
- x <- mc$x
- if(is.matrix(x))
- sqrtn <- sqrt(ncol(x))
- else
- sqrtn <- sqrt(length(x))
-
- return(list(e=eps,lower=eps.lower, upper=eps.upper, sqn = sqrtn))
-}
-
-.isOKsteps <- function(steps){
- if(!is.integer(steps))
- steps <- as.integer(steps)
- if(steps < 1){
- stop("'steps' has to be some positive integer value")
- }
- if(length(steps) != 1){
- stop("'steps' has to be of length 1")
- }
- return(invisible(NULL))
-}
-.isOKfsCor <- function(fsCor){}
- if(fsCor <= 0)
- stop("'fsCor' has to be positive")
- if(length(fsCor) != 1){
- stop("'fsCor' has to be of length 1")
- return(invisible(NULL))
-}
-
-
-.getROptICstart <- function(...){
- mc <- match.call(expand=TRUE)
- eps <- mc$eps
- dots <- mc$dots
-
- if(is.null(eps$e))){
- r.lower <- eps$sqn * eps$lower
- r.upper <- eps$sqn * eps$upper
- ICstart <- do.call(radiusMinimaxIC,
- c(list(L2Fam = mc$L2FamStart, neighbor = mc$neighbor,
- risk = mc$risk,
- loRad = r.lower, upRad = r.upper,
- verbose = mc$verbose,
- OptOrIter = mc$OptOrIter),dots))
- if(!isTRUE(all.equal(mc$fsCor, 1, tol = 1e-3))){
- neighbor at radius <- neighborRadius(ICstart)*mc$fsCor
- infMod <- InfRobModel(center = mc$L2FamStart, neighbor = mc$neighbor)
- ICstart <- do.call(optIC, c(list( model = mc$infMod, risk = mc$risk,
- verbose = mc$verbose, OptOrIter = mc$OptOrIter),
- dots))
- }
- }else{
- neighbor at radius <- eps$sqn*eps$e*mc$fsCor
- infMod <- InfRobModel(center = mc$L2FamStart, neighbor = mc$neighbor)
- ICstart <- do.call(optIC, c(list(model = mc$infMod, risk = mc$risk,
- verbose = mc$verbose, OptOrIter = mc$OptOrIter),
- dots))
- }
- return(ICstart)
-}
-
-genkStepCtrl <- function(useLast = getRobAStBaseOption("kStepUseLast"),
- withUpdateInKer = getRobAStBaseOption("withUpdateInKer"),
- IC.UpdateInKer = getRobAStBaseOption("IC.UpdateInKer"),
- withICList = getRobAStBaseOption("withICList"),
- withPICList = getRobAStBaseOption("withPICList"),
- scalename = "scale", withLogScale = TRUE){
- es.call <- match.call()
- es.list <- as.list(es.call[-1])
- es.list <- .fix.in.defaults(es.list,genkStepCtrl)
- return(es.list)
-}
-genstartCtrl<- function(initial.est = NULL, initial.est.ArgList = NULL,
- startPar = NULL, distance = CvMDist){
- es.call <- match.call()
- es.list <- as.list(es.call[-1])
- es.list <- .fix.in.defaults(es.list,genstartCtrl)
- return(es.list)
-}
-gennbCtrl <- function(neighbor = ContNeighborhood(),
- eps, eps.lower, eps.upper){
- es.call <- match.call()
- es.list <- as.list(es.call[-1])
- es.list <- .fix.in.defaults(es.list,genstartCtrl)
- return(es.list)
-}
\ No newline at end of file
Added: branches/robast-0.9/pkg/RobExtremesBuffer/internal.roptest.R
===================================================================
--- branches/robast-0.9/pkg/RobExtremesBuffer/internal.roptest.R (rev 0)
+++ branches/robast-0.9/pkg/RobExtremesBuffer/internal.roptest.R 2012-05-23 00:29:21 UTC (rev 482)
@@ -0,0 +1,145 @@
+.fix.in.defaults <- function(call.list, fun){
+ formals.fun <- formals(fun)
+ k <- length(call.list)
+ L <- length(formals.fun)
+ if("..." %in% names(formals.fun)) L <- L-1
+ for(i in 1:L){
+ if(!is(formals.fun[[i]],"name")){
+ if(!names(formals.fun)[i] %in% names(call.list)&&!is.null(formals.fun[[i]])){
+ k <- k + 1
+ call.list[[k]] <- formals.fun[[i]]
+ names(call.list)[k] <- names(formals.fun)[i]
+ }
+ }
+ }
+ return(call.list)
+
+}
+
+.pretreat <- function(x, na.rm = TRUE){
+ if(missing(x))
+ stop("'x' is missing with no default")
+ if(!is.numeric(x)){
+ if(is.data.frame(x))
+ x <- data.matrix(x)
+ else
+ x <- as.matrix(x)
+ if(!is.matrix(x))
+ stop("'x' has to be a numeric vector resp. a matrix or data.frame")
+ }
+ completecases <- complete.cases(x)
+ if(na.rm) x <- na.omit(x)
+}
+.check.eps <- function(...){
+ mc <- match.call(expand=TRUE)
+
+ eps <- eps.lower <- eps.upper <- NULL
+ if(is.null(mc$eps) && is.null(mc$eps.lower) && is.null(mc$eps.upper)){
+ eps.lower <- 0
+ eps.upper <- 0.5
+ }
+ if(is.null(mc$eps)){
+ if(!is.null(mc$eps.lower) && is.null(mc$eps.upper))
+ eps.upper <- 0.5
+ if(is.null(mc$eps.lower) && !is.null(mc$eps.upper))
+ eps.lower <- 0
+ if(length(eps.lower) != 1 || length(eps.upper) != 1)
+ stop("'eps.lower' and 'eps.upper' have to be of length 1")
+ if(!is.numeric(eps.lower) || !is.numeric(eps.upper) || eps.lower >= eps.upper)
+ stop("'eps.lower' < 'eps.upper' is not fulfilled")
+ if((eps.lower < 0) || (eps.upper > 0.5))
+ stop("'eps.lower' and 'eps.upper' have to be in [0, 0.5]")
+ }else{
+ eps <- mc$eps
+ if(length(eps) != 1)
+ stop("'eps' has to be of length 1")
+ if(eps == 0)
+ stop("'eps = 0'! => use functions 'mean' and 'sd' for estimation")
+ if((eps < 0) || (eps > 0.5))
+ stop("'eps' has to be in (0, 0.5]")
+ }
+ x <- mc$x
+ if(is.matrix(x))
+ sqrtn <- sqrt(ncol(x))
+ else
+ sqrtn <- sqrt(length(x))
+
+ return(list(e=eps,lower=eps.lower, upper=eps.upper, sqn = sqrtn))
+}
+
+.isOKsteps <- function(steps){
+ if(!is.integer(steps))
+ steps <- as.integer(steps)
+ if(steps < 1){
+ stop("'steps' has to be some positive integer value")
+ }
+ if(length(steps) != 1){
+ stop("'steps' has to be of length 1")
+ }
+ return(invisible(NULL))
+}
+.isOKfsCor <- function(fsCor){}
+ if(fsCor <= 0)
+ stop("'fsCor' has to be positive")
+ if(length(fsCor) != 1){
+ stop("'fsCor' has to be of length 1")
+ return(invisible(NULL))
+}
+
+
+.getROptICstart <- function(...){
+ mc <- match.call(expand=TRUE)
+ eps <- mc$eps
+ dots <- mc$dots
+
+ if(is.null(eps$e))){
+ r.lower <- eps$sqn * eps$lower
+ r.upper <- eps$sqn * eps$upper
+ ICstart <- do.call(radiusMinimaxIC,
+ c(list(L2Fam = mc$L2FamStart, neighbor = mc$neighbor,
+ risk = mc$risk,
+ loRad = r.lower, upRad = r.upper,
+ verbose = mc$verbose,
+ OptOrIter = mc$OptOrIter),dots))
+ if(!isTRUE(all.equal(mc$fsCor, 1, tol = 1e-3))){
+ neighbor at radius <- neighborRadius(ICstart)*mc$fsCor
+ infMod <- InfRobModel(center = mc$L2FamStart, neighbor = mc$neighbor)
+ ICstart <- do.call(optIC, c(list( model = mc$infMod, risk = mc$risk,
+ verbose = mc$verbose, OptOrIter = mc$OptOrIter),
+ dots))
+ }
+ }else{
+ neighbor at radius <- eps$sqn*eps$e*mc$fsCor
+ infMod <- InfRobModel(center = mc$L2FamStart, neighbor = mc$neighbor)
+ ICstart <- do.call(optIC, c(list(model = mc$infMod, risk = mc$risk,
+ verbose = mc$verbose, OptOrIter = mc$OptOrIter),
+ dots))
+ }
+ return(ICstart)
+}
+
+genkStepCtrl <- function(useLast = getRobAStBaseOption("kStepUseLast"),
+ withUpdateInKer = getRobAStBaseOption("withUpdateInKer"),
+ IC.UpdateInKer = getRobAStBaseOption("IC.UpdateInKer"),
+ withICList = getRobAStBaseOption("withICList"),
+ withPICList = getRobAStBaseOption("withPICList"),
+ scalename = "scale", withLogScale = TRUE){
+ es.call <- match.call()
+ es.list <- as.list(es.call[-1])
+ es.list <- .fix.in.defaults(es.list,genkStepCtrl)
+ return(es.list)
+}
+genstartCtrl<- function(initial.est = NULL, initial.est.ArgList = NULL,
+ startPar = NULL, distance = CvMDist){
+ es.call <- match.call()
+ es.list <- as.list(es.call[-1])
+ es.list <- .fix.in.defaults(es.list,genstartCtrl)
+ return(es.list)
+}
+gennbCtrl <- function(neighbor = ContNeighborhood(),
+ eps, eps.lower, eps.upper){
+ es.call <- match.call()
+ es.list <- as.list(es.call[-1])
+ es.list <- .fix.in.defaults(es.list,genstartCtrl)
+ return(es.list)
+}
\ No newline at end of file
Deleted: branches/robast-0.9/pkg/RobExtremesBuffer/roptest.new.R
===================================================================
--- branches/robast-0.9/pkg/RobExtremesBuffer/roptest.new.R 2012-05-23 00:17:44 UTC (rev 481)
+++ branches/robast-0.9/pkg/RobExtremesBuffer/roptest.new.R 2012-05-23 00:29:21 UTC (rev 482)
@@ -1,89 +0,0 @@
-###############################################################################
-## Optimally robust estimation
-###############################################################################
-roptest <- function(x, L2Fam, fsCor = 1,
- risk = asMSE(), steps = 1L,
- verbose = NULL,
- OptOrIter = "iterate",
- nbCtrl = gennbCtrl(neighbor = ContNeighborhood(),
- eps, eps.lower, eps.upper)
- startCtrl = genstartCtrl(initial.est = NULL,
- initial.est.ArgList = NULL,
- startPar = NULL, distance = CvMDist),
- kstepCtrl = genkstepCtrl(
- useLast = getRobAStBaseOption("kStepUseLast"),
- withUpdateInKer = getRobAStBaseOption("withUpdateInKer"),
- IC.UpdateInKer = getRobAStBaseOption("IC.UpdateInKer"),
- withICList = getRobAStBaseOption("withICList"),
- withPICList = getRobAStBaseOption("withPICList"),
- withLogScale = TRUE),
- na.rm = TRUE, ...){
-
- es.call <- match.call()
- dots <- match.call(expand=FALSE)$dots
- es.list <- as.list(es.call[-1])
- es.list <- .fix.in.defaults(es.list,roptest)
- es.list <- c(es.list,nbCtrl)
- es.list$dots <- dots
-
- if(missing(verbose)|| is.null(verbose))
- es.list$verbose <- getRobAStBaseOption("all.verbose")
-
- if(missing(L2Fam))
- stop("'L2Fam' is missing with no default")
-
- x <- .pretreat(x,na.rm)
-
- es.list$eps <- do.call(.check.eps, args=es.list)
-
- .isOKfsCor(fsCor)
-
- .isOKsteps(steps)
-
- if(is.null(startCtrl$initial.est))
- startCtrl$initial.est <- MDEstimator(x = x, ParamFamily = L2Fam,
- distance = startCtrl$distance,
- startPar = startCtrl$startPar, ...)
- nrvalues <- length(L2Fam at param)
- initial.est <- kStepEstimator.start(initial.est, x = x,
- nrvalues = nrvalues, na.rm = na.rm,
- L2Fam = L2Fam,
- startList = startCtrl$initial.est.ArgList)
-
-
- newParam <- param(L2Fam)
- main(newParam)[] <- as.numeric(initial.est)
- L2FamStart <- modifyModel(L2Fam, newParam)
-
- ICstart <- do.call(.getROptICstart, args=es.list)
-
- res <- kStepEstimator(x, IC = ICstart, start = initial.est, steps = steps,
- useLast = kStepCtrl$useLast,
- withUpdateInKer = kStepCtrl$withUpdateInKer,
- IC.UpdateInKer = kStepCtrl$IC.UpdateInKer,
- withICList = kStepCtrl$withICList,
- withPICList = kStepCtrl$withPICList,
- na.rm = na.rm,
- scalename = kstepCtrl$scalename,
- withLogScale = kstepCtrl$withLogScale)
-
-
- res at estimate.call <- es.call
- Infos <- matrix(c("roptest",
- paste(steps, "-step estimate for ", name(L2Fam), sep = "")),
- ncol = 2)
- colnames(Infos) <- c("method", "message")
-
- if(! distrMod:::.isUnitMatrix(trafo(L2Fam)))
- Infos <- rbind(Infos, c("roptest",
- paste("computation of IC",
- ifelse(withUpdateInKer,"with","without") ,
- "modification in ker(trafo)")))
-
- Infos <- rbind(Infos, c("roptest",
- paste("computation of IC, asvar and asbias via useLast =", useLast)))
- Infos(res) <- Infos
- res at completecases <- completecases
- res at start <- initial.est
- return(res)
-}
Added: branches/robast-0.9/pkg/RobExtremesBuffer/roptest.new.R
===================================================================
--- branches/robast-0.9/pkg/RobExtremesBuffer/roptest.new.R (rev 0)
+++ branches/robast-0.9/pkg/RobExtremesBuffer/roptest.new.R 2012-05-23 00:29:21 UTC (rev 482)
@@ -0,0 +1,92 @@
+###############################################################################
+## Optimally robust estimation
+###############################################################################
+roptest <- function(x, L2Fam, fsCor = 1,
+ risk = asMSE(), steps = 1L,
+ verbose = NULL,
+ OptOrIter = "iterate",
+ nbCtrl = gennbCtrl(neighbor = ContNeighborhood(),
+ eps, eps.lower, eps.upper)
+ startCtrl = genstartCtrl(initial.est = NULL,
+ initial.est.ArgList = NULL,
+ startPar = NULL, distance = CvMDist),
+ kstepCtrl = genkstepCtrl(
+ useLast = getRobAStBaseOption("kStepUseLast"),
+ withUpdateInKer = getRobAStBaseOption("withUpdateInKer"),
+ IC.UpdateInKer = getRobAStBaseOption("IC.UpdateInKer"),
+ withICList = getRobAStBaseOption("withICList"),
+ withPICList = getRobAStBaseOption("withPICList"),
+ withLogScale = TRUE),
+ na.rm = TRUE, ...){
+
+ es.call <- match.call()
+ dots <- match.call(expand=FALSE)$dots
+ es.list <- as.list(es.call[-1])
+ es.list <- .fix.in.defaults(es.list,roptest)
+ es.list <- c(es.list,nbCtrl)
+ es.list$dots <- dots
+
+ if(missing(verbose)|| is.null(verbose))
+ es.list$verbose <- getRobAStBaseOption("all.verbose")
+
+ if(missing(L2Fam))
+ stop("'L2Fam' is missing with no default")
+
+ x <- .pretreat(x,na.rm)
+
+ es.list$eps <- do.call(.check.eps, args=es.list)
+
+ .isOKfsCor(fsCor)
+
+ .isOKsteps(steps)
+
+ if(is.null(startCtrl$initial.est))
+ startCtrl$initial.est <- MDEstimator(x = x, ParamFamily = L2Fam,
+ distance = startCtrl$distance,
+ startPar = startCtrl$startPar, ...)
+ nrvalues <- length(L2Fam at param)
+ initial.est <- kStepEstimator.start(initial.est, x = x,
+ nrvalues = nrvalues, na.rm = na.rm,
+ L2Fam = L2Fam,
+ startList = startCtrl$initial.est.ArgList)
+
+
+ newParam <- param(L2Fam)
+ main(newParam)[] <- as.numeric(initial.est)
+ L2FamStart <- modifyModel(L2Fam, newParam)
+
+ es.list0 <- es.list
+ es.list$risk <- NULL
+ es.list$L2Fam <- NULL
+ ICstart <- do.call(getstartIC, args=c(list(model=L2Fam,risk=risk),es.list))
+
+ res <- kStepEstimator(x, IC = ICstart, start = initial.est, steps = steps,
+ useLast = kStepCtrl$useLast,
+ withUpdateInKer = kStepCtrl$withUpdateInKer,
+ IC.UpdateInKer = kStepCtrl$IC.UpdateInKer,
+ withICList = kStepCtrl$withICList,
+ withPICList = kStepCtrl$withPICList,
+ na.rm = na.rm,
+ scalename = kstepCtrl$scalename,
+ withLogScale = kstepCtrl$withLogScale)
+
+
+ res at estimate.call <- es.call
+ Infos <- matrix(c("roptest",
+ paste(steps, "-step estimate for ", name(L2Fam), sep = "")),
+ ncol = 2)
+ colnames(Infos) <- c("method", "message")
+
+ if(! distrMod:::.isUnitMatrix(trafo(L2Fam)))
+ Infos <- rbind(Infos, c("roptest",
+ paste("computation of IC",
+ ifelse(withUpdateInKer,"with","without") ,
+ "modification in ker(trafo)")))
+
+ Infos <- rbind(Infos, c("roptest",
+ paste("computation of IC, asvar and asbias via useLast =", useLast)))
+ Infos(res) <- Infos
+ res at completecases <- completecases
+ res at start <- initial.est
+ return(res)
+}
More information about the Robast-commits
mailing list