[Robast-commits] r151 - in branches/robast-0.6/pkg/ROptEst: . R man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Aug 7 10:28:07 CEST 2008
Author: stamats
Date: 2008-08-07 10:28:07 +0200 (Thu, 07 Aug 2008)
New Revision: 151
Added:
branches/robast-0.6/pkg/ROptEst/R/getModifyIC.R
branches/robast-0.6/pkg/ROptEst/man/getModifyIC.Rd
Modified:
branches/robast-0.6/pkg/ROptEst/DESCRIPTION
branches/robast-0.6/pkg/ROptEst/NAMESPACE
branches/robast-0.6/pkg/ROptEst/R/AllGeneric.R
branches/robast-0.6/pkg/ROptEst/R/optIC.R
branches/robast-0.6/pkg/ROptEst/man/getAsRisk.Rd
Log:
new generic function getModifyIC with corresponding methods ...
Modified: branches/robast-0.6/pkg/ROptEst/DESCRIPTION
===================================================================
--- branches/robast-0.6/pkg/ROptEst/DESCRIPTION 2008-08-07 08:19:02 UTC (rev 150)
+++ branches/robast-0.6/pkg/ROptEst/DESCRIPTION 2008-08-07 08:28:07 UTC (rev 151)
@@ -1,6 +1,6 @@
Package: ROptEst
Version: 0.6.0
-Date: 2008-08-01
+Date: 2008-08-07
Title: Optimally robust estimation
Description: Optimally robust estimation using S4 classes and methods
Depends: R(>= 2.4.0), methods, distr(>= 2.0), distrEx(>= 2.0), distrMod(>= 2.0), RandVar(>= 0.6.2), RobAStBase
Modified: branches/robast-0.6/pkg/ROptEst/NAMESPACE
===================================================================
--- branches/robast-0.6/pkg/ROptEst/NAMESPACE 2008-08-07 08:19:02 UTC (rev 150)
+++ branches/robast-0.6/pkg/ROptEst/NAMESPACE 2008-08-07 08:28:07 UTC (rev 151)
@@ -22,7 +22,8 @@
"leastFavorableRadius",
"lowerCaseRadius",
"minmaxBias", "getBiasIC",
- "getL1normL2deriv")
+ "getL1normL2deriv",
+ "getModifyIC")
exportMethods("updateNorm")
export("getL2normL2deriv")
export("roptest")
Modified: branches/robast-0.6/pkg/ROptEst/R/AllGeneric.R
===================================================================
--- branches/robast-0.6/pkg/ROptEst/R/AllGeneric.R 2008-08-07 08:19:02 UTC (rev 150)
+++ branches/robast-0.6/pkg/ROptEst/R/AllGeneric.R 2008-08-07 08:28:07 UTC (rev 151)
@@ -71,3 +71,6 @@
if(!isGeneric("updateNorm")){
setGeneric("updateNorm", function(normtype, ...) standardGeneric("updateNorm"))
}
+if(!isGeneric("getModifyIC")){
+ setGeneric("getModifyIC", function(L2FamIC, neighbor, risk) standardGeneric("getModifyIC"))
+}
Added: branches/robast-0.6/pkg/ROptEst/R/getModifyIC.R
===================================================================
--- branches/robast-0.6/pkg/ROptEst/R/getModifyIC.R (rev 0)
+++ branches/robast-0.6/pkg/ROptEst/R/getModifyIC.R 2008-08-07 08:28:07 UTC (rev 151)
@@ -0,0 +1,136 @@
+###############################################################################
+## internal functions/methods to fill slot modifyIC
+###############################################################################
+
+setMethod("getModifyIC", signature(L2FamIC = "L2ParamFamily",
+ neighbor = "Neighborhood", risk = "asRisk"),
+ function(L2FamIC, neighbor, risk){
+ modIC <- function(L2Fam, IC){}
+ body(modIC) <- substitute({ infMod <- InfRobModel(L2Fam, nghb)
+ optIC(infMod, R) },
+ list(nghb = neighbor, R = risk))
+ return(modIC)
+ })
+
+setMethod("getModifyIC", signature(L2FamIC = "L2LocationFamily",
+ neighbor = "UncondNeighborhood", risk = "asGRisk"),
+ function(L2FamIC, neighbor, risk){
+ modIC <- function(L2Fam, IC){
+ D <- distribution(eval(CallL2Fam(IC)))
+ if(is(L2Fam, "L2LocationFamily") && is(distribution(L2Fam), class(D))){
+ CallL2Fam(IC) <- fam.call(L2Fam)
+ return(IC)
+ }else{
+ makeIC(L2Fam, IC)
+ }
+ }
+ return(modIC)
+ })
+
+setMethod("getModifyIC", signature(L2FamIC = "L2ScaleFamily",
+ neighbor = "ContNeighborhood", risk = "asGRisk"),
+ function(L2FamIC, neighbor, risk){
+ modIC <- function(L2Fam, IC){
+ ICL2Fam <- eval(CallL2Fam(IC))
+ if(is(L2Fam, "L2ScaleFamily") && is(distribution(L2Fam), class(distribution(ICL2Fam)))){
+ sdneu <- main(L2Fam)
+ sdalt <- main(ICL2Fam)
+ r <- neighborRadius(IC)
+ w <- weight(IC)
+ clip(w) <- sdneu*clip(w)/sdalt
+ cent(w) <- sdalt*cent(w)/sdneu
+ stand(w) <- sdneu^2*stand(w)/sdalt^2
+ weight(w) <- getweight(w, neighbor = ContNeighborhood(radius = r),
+ biastype = biastype(IC),
+ normW = normtype(IC))
+ A <- sdneu^2*stand(IC)/sdalt^2
+ b <- sdneu*clip(IC)/sdalt
+ res <- list(A = A, a = sdneu*cent(IC)/sdalt, b = b, d = NULL,
+ risk = list(asMSE = A, asBias = b, asCov = A-r^2*b^2),
+ info = Infos(IC), w = w,
+ normtype = normtype(IC), biastype = biastype(IC),
+ modifyIC = modifyIC(IC))
+ IC <- generateIC(neighbor = ContNeighborhood(radius = r),
+ L2Fam = L2Fam, res = res)
+ addInfo(IC) <- c("modifyIC", "The IC has been modified")
+ addInfo(IC) <- c("modifyIC", "The entries in 'Infos' may be wrong")
+ return(IC)
+ }else{
+ makeIC(L2Fam, IC)
+ }
+ }
+ return(modIC)
+ })
+
+setMethod("getModifyIC", signature(L2FamIC = "L2ScaleFamily",
+ neighbor = "TotalVarNeighborhood", risk = "asGRisk"),
+ function(L2FamIC, neighbor, risk){
+ modIC <- function(L2Fam, IC){
+ ICL2Fam <- eval(CallL2Fam(IC))
+ if(is(L2Fam, "L2ScaleFamily") && is(distribution(L2Fam), class(distribution(ICL2Fam)))){
+ sdneu <- main(L2Fam)
+ sdalt <- main(ICL2Fam)
+ r <- neighborRadius(IC)
+ w <- weight(IC)
+ clip(w) <- sdneu*clip(w)/sdalt
+ stand(w) <- sdneu^2*stand(w)/sdalt^2
+ weight(w) <- getweight(w, neighbor = TotalVarNeighborhood(radius = r),
+ biastype = biastype(IC),
+ normW = normtype(IC))
+ A <- sdneu^2*stand(IC)/sdalt^2
+ blo <- sdneu*clipLo(IC)/sdalt
+ b <- sdneu*clipUp(IC)/sdalt - blo
+ res <- list(A = A, a = blo, b = b, d = NULL,
+ risk = list(asMSE = A, asBias = b, asCov = A-r^2*b^2),
+ info = Infos(IC), w = w,
+ normtype = normtype(IC), biastype = biastype(IC),
+ modifyIC = modifyIC(IC))
+ IC <- generateIC(neighbor = TotalVarNeighborhood(radius = r),
+ L2Fam = L2Fam, res = res)
+ addInfo(IC) <- c("modifyIC", "The IC has been modified")
+ addInfo(IC) <- c("modifyIC", "The entries in 'Infos' may be wrong")
+ return(IC)
+ }else{
+ makeIC(L2Fam, IC)
+ }
+ }
+ return(modIC)
+ })
+
+setMethod("getModifyIC", signature(L2FamIC = "L2LocationScaleFamily",
+ neighbor = "ContNeighborhood", risk = "asGRisk"),
+ function(L2FamIC, neighbor, risk){
+ modIC <- function(L2Fam, IC){
+ ICL2Fam <- eval(CallL2Fam(IC))
+ if(is(L2Fam, "L2LocationScaleFamily") && is(distribution(L2Fam), class(distribution(ICL2Fam)))){
+ sdneu <- main(L2Fam)[2]
+ sdalt <- main(ICL2Fam)[2]
+ r <- neighborRadius(IC)
+ w <- weight(IC)
+ clip(w) <- sdneu*clip(w)/sdalt
+ cent(w) <- sdalt*cent(w)/sdneu
+ stand(w) <- sdneu^2*stand(w)/sdalt^2
+ weight(w) <- getweight(w, neighbor = ContNeighborhood(radius = r),
+ biastype = biastype(IC),
+ normW = normtype(IC))
+ A <- sdneu^2*stand(IC)/sdalt^2
+ b <- sdneu*clip(IC)/sdalt
+ a <- sdneu*cent(IC)/sdalt
+ mse <- sum(diag(A))
+ res <- list(A = A, a = sdneu*cent(IC)/sdalt, b = b, d = NULL,
+ risk = list(asMSE = mse, asBias = b,
+ trAsCov = mse - r^2*b^2),
+ info = Infos(IC), w = w,
+ normtype = normtype(IC), biastype = biastype(IC),
+ modifyIC = modifyIC(IC))
+ IC <- generateIC(neighbor = ContNeighborhood(radius = r),
+ L2Fam = L2Fam, res = res)
+ addInfo(IC) <- c("modifyIC", "The IC has been modified")
+ addInfo(IC) <- c("modifyIC", "The entries in 'Infos' may be wrong")
+ return(IC)
+ }else{
+ makeIC(L2Fam, IC)
+ }
+ }
+ return(modIC)
+ })
Modified: branches/robast-0.6/pkg/ROptEst/R/optIC.R
===================================================================
--- branches/robast-0.6/pkg/ROptEst/R/optIC.R 2008-08-07 08:19:02 UTC (rev 150)
+++ branches/robast-0.6/pkg/ROptEst/R/optIC.R 2008-08-07 08:28:07 UTC (rev 151)
@@ -17,11 +17,9 @@
noLow = noLow, verbose = verbose)
options(ow)
res$info <- c("optIC", res$info)
- modIC <- function(L2Fam, IC){
- infMod <- InfRobModel(L2Fam, model at neighbor)
- optIC(infMod, risk)
- }
- res <- c(res, modifyIC = modIC)
+ res <- c(res, modifyIC = getModifyIC(L2FamIC = model at center,
+ neighbor = model at neighbor,
+ risk = risk))
return(generateIC(model at neighbor, model at center, res))
}else{
if(is(model at center@distribution, "UnivariateDistribution")){
@@ -55,13 +53,11 @@
verbose = verbose)
options(ow)
res$info <- c("optIC", res$info)
- modIC <- function(L2Fam, IC){
- infMod <- InfRobModel(L2Fam, model at neighbor)
- optIC(infMod, risk)
- }
- res <- c(res, modifyIC = modIC)
- return(generateIC(model at neighbor, model at center, res))
- }else{
+ res <- c(res, modifyIC = getModifyIC(L2FamIC = model at center,
+ neighbor = model at neighbor,
+ risk = risk))
+ return(generateIC(model at neighbor, model at center, res))
+ }else{
stop("not yet implemented")
}
}
@@ -88,11 +84,9 @@
res$info <- c("optIC", "optIC", res$info, "Optimal IC for 'InfRobModel' with 'ContNeighborhood'!!!")
else
res$info <- c("optIC", res$info)
- modIC <- function(L2Fam, IC){
- infMod <- InfRobModel(L2Fam, model at neighbor)
- optIC(infMod, risk)
- }
- res <- c(res, modifyIC = modIC)
+ res <- c(res, modifyIC = getModifyIC(L2FamIC = model at center,
+ neighbor = model at neighbor,
+ risk = risk))
return(generateIC(TotalVarNeighborhood(radius = model at neighbor@radius), model at center, res))
}else{
stop("restricted to 1-dimensional parameteric models")
@@ -121,11 +115,9 @@
res$info <- c("optIC", "optIC", res$info, "Optimal IC for 'FixRobModel' with 'ContNeighborhood'!!!")
else
res$info <- c("optIC", res$info)
- modIC <- function(L2Fam, IC){
- infMod <- InfRobModel(L2Fam, model at neighbor)
- optIC(infMod, risk)
- }
- res <- c(res, modifyIC = modIC)
+ res <- c(res, modifyIC = getModifyIC(L2FamIC = model at center,
+ neighbor = model at neighbor,
+ risk = risk))
return(generateIC(TotalVarNeighborhood(radius = model at neighbor@radius), model at center, res))
}else{
stop("restricted to 1-dimensional parametric models")
Modified: branches/robast-0.6/pkg/ROptEst/man/getAsRisk.Rd
===================================================================
--- branches/robast-0.6/pkg/ROptEst/man/getAsRisk.Rd 2008-08-07 08:19:02 UTC (rev 150)
+++ branches/robast-0.6/pkg/ROptEst/man/getAsRisk.Rd 2008-08-07 08:28:07 UTC (rev 151)
@@ -54,7 +54,7 @@
neighbor, biastype, clip, cent, stand)
\S4method{getAsRisk}{asCov,RealRandVariable,ContNeighborhood,ANY}(risk, L2deriv, neighbor,
- biastype, Distr, clip, cent, stand,
+ biastype, Distr, cent, stand,
V.comp = matrix(TRUE, ncol = nrow(stand), nrow = nrow(stand)), w)
\S4method{getAsRisk}{trAsCov,UnivariateDistribution,UncondNeighborhood,ANY}(risk, L2deriv,
Added: branches/robast-0.6/pkg/ROptEst/man/getModifyIC.Rd
===================================================================
--- branches/robast-0.6/pkg/ROptEst/man/getModifyIC.Rd (rev 0)
+++ branches/robast-0.6/pkg/ROptEst/man/getModifyIC.Rd 2008-08-07 08:28:07 UTC (rev 151)
@@ -0,0 +1,40 @@
+\name{getModifyIC}
+\alias{getModifyIC}
+\alias{getModifyIC-methods}
+\alias{getModifyIC,L2ParamFamily,Neighborhood,asRisk-method}
+\alias{getModifyIC,L2LocationFamily,UncondNeighborhood,asGRisk-method}
+\alias{getModifyIC,L2ScaleFamily,ContNeighborhood,asGRisk-method}
+\alias{getModifyIC,L2ScaleFamily,TotalVarNeighborhood,asGRisk-method}
+\alias{getModifyIC,L2LocationScaleFamily,ContNeighborhood,asGRisk-method}
+
+\title{Generic Function for the Computation of Functions for Slot modifyIC}
+\description{
+ This function is used by internal computations and is rarely called directly.
+}
+\usage{
+getModifyIC(L2FamIC, neighbor, risk)
+\S4method{getModifyIC}{L2ParamFamily,Neighborhood,asRisk}(L2FamIC, neighbor, risk)
+\S4method{getModifyIC}{L2LocationFamily,UncondNeighborhood,asGRisk}(L2FamIC, neighbor, risk)
+\S4method{getModifyIC}{L2ScaleFamily,ContNeighborhood,asGRisk}(L2FamIC, neighbor, risk)
+\S4method{getModifyIC}{L2ScaleFamily,TotalVarNeighborhood,asGRisk}(L2FamIC, neighbor, risk)
+\S4method{getModifyIC}{L2LocationScaleFamily,ContNeighborhood,asGRisk}(L2FamIC, neighbor, risk)
+}
+\arguments{
+ \item{L2FamIC}{ object of class \code{L2ParamFamily}. }
+ \item{neighbor}{ object of class \code{"Neighborhood"}. }
+ \item{risk}{ object of class \code{"RiskType"} }
+}
+\details{ This function is used for internal computations. }
+\value{ Function for slot \code{modifyIC} of \code{IC}s }
+\references{
+ Rieder, H. (1994) \emph{Robust Asymptotic Statistics}. New York: Springer.
+
+ Kohl, M. (2005) \emph{Numerical Contributions to the Asymptotic Theory of Robustness}.
+ Bayreuth: Dissertation.
+}
+\author{Matthias Kohl \email{Matthias.Kohl at stamats.de}}
+%\note{}
+\seealso{\code{\link{optIC}}, \code{\link[RobAStBase]{IC-class}}}
+%\examples{}
+\concept{influence curve}
+\keyword{robust}
More information about the Robast-commits
mailing list