[Robast-commits] r459 - in branches/robast-0.9/pkg: . ROptReg ROptReg/R ROptReg/inst ROptReg/man
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Jan 31 13:15:30 CET 2012
Author: ruckdeschel
Date: 2012-01-31 13:15:29 +0100 (Tue, 31 Jan 2012)
New Revision: 459
Added:
branches/robast-0.9/pkg/ROptReg/
branches/robast-0.9/pkg/ROptReg/DESCRIPTION
branches/robast-0.9/pkg/ROptReg/NAMESPACE
branches/robast-0.9/pkg/ROptReg/R/
branches/robast-0.9/pkg/ROptReg/R/AllClass.R
branches/robast-0.9/pkg/ROptReg/R/AllGeneric.R
branches/robast-0.9/pkg/ROptReg/R/AllShow.R
branches/robast-0.9/pkg/ROptReg/R/Av1CondContIC.R
branches/robast-0.9/pkg/ROptReg/R/Av1CondTotalVarIC.R
branches/robast-0.9/pkg/ROptReg/R/Av2CondContIC.R
branches/robast-0.9/pkg/ROptReg/R/CondContIC.R
branches/robast-0.9/pkg/ROptReg/R/CondIC.R
branches/robast-0.9/pkg/ROptReg/R/CondNeighborhood.R
branches/robast-0.9/pkg/ROptReg/R/CondTotalVarIC.R
branches/robast-0.9/pkg/ROptReg/R/ContIC.R
branches/robast-0.9/pkg/ROptReg/R/Expectation.R
branches/robast-0.9/pkg/ROptReg/R/FixRobRegrTypeModel.R
branches/robast-0.9/pkg/ROptReg/R/IC.R
branches/robast-0.9/pkg/ROptReg/R/InfRobRegTypeModel.R
branches/robast-0.9/pkg/ROptReg/R/L2RegTypeFamily.R
branches/robast-0.9/pkg/ROptReg/R/NormRegFamilies.R
branches/robast-0.9/pkg/ROptReg/R/RegTypeFamily.R
branches/robast-0.9/pkg/ROptReg/R/TotalVarIC.R
branches/robast-0.9/pkg/ROptReg/R/getAsRiskRegTS.R
branches/robast-0.9/pkg/ROptReg/R/getFiRiskRegTS.R
branches/robast-0.9/pkg/ROptReg/R/getFixClipRegTS.R
branches/robast-0.9/pkg/ROptReg/R/getFixRobRegTypeIC_fiUnOvShoot.R
branches/robast-0.9/pkg/ROptReg/R/getIneffDiff.R
branches/robast-0.9/pkg/ROptReg/R/getInfCentRegTS.R
branches/robast-0.9/pkg/ROptReg/R/getInfClipRegTS.R
branches/robast-0.9/pkg/ROptReg/R/getInfGammaRegTS.R
branches/robast-0.9/pkg/ROptReg/R/getInfRobRegTypeIC_asBias.R
branches/robast-0.9/pkg/ROptReg/R/getInfRobRegTypeIC_asCov.R
branches/robast-0.9/pkg/ROptReg/R/getInfRobRegTypeIC_asGRisk_c0.R
branches/robast-0.9/pkg/ROptReg/R/getInfRobRegTypeIC_asGRisk_c1.R
branches/robast-0.9/pkg/ROptReg/R/getInfRobRegTypeIC_asGRisk_c2.R
branches/robast-0.9/pkg/ROptReg/R/getInfRobRegTypeIC_asGRisk_v1.R
branches/robast-0.9/pkg/ROptReg/R/getInfRobRegTypeIC_asUnOvShoot.R
branches/robast-0.9/pkg/ROptReg/R/getInfStandRegTS.R
branches/robast-0.9/pkg/ROptReg/R/leastFavorableRadius.R
branches/robast-0.9/pkg/ROptReg/R/optIC.R
branches/robast-0.9/pkg/ROptReg/R/radiusMinimaxIC.R
branches/robast-0.9/pkg/ROptReg/inst/
branches/robast-0.9/pkg/ROptReg/inst/CITATION
branches/robast-0.9/pkg/ROptReg/inst/NEWS
branches/robast-0.9/pkg/ROptReg/inst/TOBEDONE
branches/robast-0.9/pkg/ROptReg/inst/scripts/
branches/robast-0.9/pkg/ROptReg/man/
branches/robast-0.9/pkg/ROptReg/man/Av1CondContIC-class.Rd
branches/robast-0.9/pkg/ROptReg/man/Av1CondContIC.Rd
branches/robast-0.9/pkg/ROptReg/man/Av1CondContNeighborhood-class.Rd
branches/robast-0.9/pkg/ROptReg/man/Av1CondContNeighborhood.Rd
branches/robast-0.9/pkg/ROptReg/man/Av1CondNeighborhood-class.Rd
branches/robast-0.9/pkg/ROptReg/man/Av1CondTotalVarIC-class.Rd
branches/robast-0.9/pkg/ROptReg/man/Av1CondTotalVarIC.Rd
branches/robast-0.9/pkg/ROptReg/man/Av1CondTotalVarNeighborhood-class.Rd
branches/robast-0.9/pkg/ROptReg/man/Av1CondTotalVarNeighborhood.Rd
branches/robast-0.9/pkg/ROptReg/man/Av2CondContIC-class.Rd
branches/robast-0.9/pkg/ROptReg/man/Av2CondContIC.Rd
branches/robast-0.9/pkg/ROptReg/man/Av2CondContNeighborhood-class.Rd
branches/robast-0.9/pkg/ROptReg/man/Av2CondContNeighborhood.Rd
branches/robast-0.9/pkg/ROptReg/man/Av2CondNeighborhood-class.Rd
branches/robast-0.9/pkg/ROptReg/man/AvCondNeighborhood-class.Rd
branches/robast-0.9/pkg/ROptReg/man/CondContIC-class.Rd
branches/robast-0.9/pkg/ROptReg/man/CondContIC.Rd
branches/robast-0.9/pkg/ROptReg/man/CondContNeighborhood-class.Rd
branches/robast-0.9/pkg/ROptReg/man/CondContNeighborhood.Rd
branches/robast-0.9/pkg/ROptReg/man/CondIC-class.Rd
branches/robast-0.9/pkg/ROptReg/man/CondIC.Rd
branches/robast-0.9/pkg/ROptReg/man/CondNeighborhood-class.Rd
branches/robast-0.9/pkg/ROptReg/man/CondTotalVarIC-class.Rd
branches/robast-0.9/pkg/ROptReg/man/CondTotalVarIC.Rd
branches/robast-0.9/pkg/ROptReg/man/CondTotalVarNeighborhood-class.Rd
branches/robast-0.9/pkg/ROptReg/man/CondTotalVarNeighborhood.Rd
branches/robast-0.9/pkg/ROptReg/man/FixRobRegTypeModel-class.Rd
branches/robast-0.9/pkg/ROptReg/man/FixRobRegTypeModel.Rd
branches/robast-0.9/pkg/ROptReg/man/InfRobRegTypeModel-class.Rd
branches/robast-0.9/pkg/ROptReg/man/InfRobRegTypeModel.Rd
branches/robast-0.9/pkg/ROptReg/man/L2RegTypeFamily-class.Rd
branches/robast-0.9/pkg/ROptReg/man/L2RegTypeFamily.Rd
branches/robast-0.9/pkg/ROptReg/man/NormLinRegFamily.Rd
branches/robast-0.9/pkg/ROptReg/man/NormLinRegInterceptFamily.Rd
branches/robast-0.9/pkg/ROptReg/man/NormLinRegScaleFamily.Rd
branches/robast-0.9/pkg/ROptReg/man/RegTypeFamily-class.Rd
branches/robast-0.9/pkg/ROptReg/man/RegTypeFamily.Rd
branches/robast-0.9/pkg/ROptReg/man/generateIC-methods.Rd
branches/robast-0.9/pkg/ROptReg/man/getAsRiskRegTS.Rd
branches/robast-0.9/pkg/ROptReg/man/getFiRiskRegTS.Rd
branches/robast-0.9/pkg/ROptReg/man/getFixClipRegTS.Rd
branches/robast-0.9/pkg/ROptReg/man/getFixRobRegTypeIC.Rd
branches/robast-0.9/pkg/ROptReg/man/getIneffDiff-methods.Rd
branches/robast-0.9/pkg/ROptReg/man/getInfCentRegTS.Rd
branches/robast-0.9/pkg/ROptReg/man/getInfClipRegTS.Rd
branches/robast-0.9/pkg/ROptReg/man/getInfGammaRegTS.Rd
branches/robast-0.9/pkg/ROptReg/man/getInfRobRegTypeIC.Rd
branches/robast-0.9/pkg/ROptReg/man/getInfStandRegTS.Rd
branches/robast-0.9/pkg/ROptReg/man/leastFavorableRadius-methods.Rd
branches/robast-0.9/pkg/ROptReg/man/optIC-methods.Rd
branches/robast-0.9/pkg/ROptReg/man/radiusMinimaxIC-methods.Rd
Log:
Starting point for new package ROptReg created
Added: branches/robast-0.9/pkg/ROptReg/DESCRIPTION
===================================================================
--- branches/robast-0.9/pkg/ROptReg/DESCRIPTION (rev 0)
+++ branches/robast-0.9/pkg/ROptReg/DESCRIPTION 2012-01-31 12:15:29 UTC (rev 459)
@@ -0,0 +1,17 @@
+Package: ROptReg
+Version: 0.9
+Date: 2012-02-01
+Title: Optimally robust estimation for regression-type models
+Description: Optimally robust estimation for regression-type models using S4 classes and
+ methods (based on distrMod, RobAStBase, and ROptEst)
+Depends: R (>= 2.14.0), methods, distr(>= 2.3), distrEx(>= 2.3), RandVar(>= 0.8),
+ distrMod(>=2.4), RobAStBase(>=0.8), ROptEst(>=0.8)
+Author: Matthias Kohl, Peter Ruckdeschel, Daria Pupashenko
+Maintainer: Peter Ruckdeschel <peter.ruckdeschel at itwm.fraunhofer.de>
+LazyLoad: yes
+ByteCompile: yes
+License: LGPL-3
+URL: http://robast.r-forge.r-project.org/
+LastChangedDate: {$LastChangedDate: 2011-09-30 11:10:33 +0200 (Fr, 30 Sep 2011) $}
+LastChangedRevision: {$LastChangedRevision: 453 $}
+SVNRevision: 439
Added: branches/robast-0.9/pkg/ROptReg/NAMESPACE
===================================================================
--- branches/robast-0.9/pkg/ROptReg/NAMESPACE (rev 0)
+++ branches/robast-0.9/pkg/ROptReg/NAMESPACE 2012-01-31 12:15:29 UTC (rev 459)
@@ -0,0 +1,92 @@
+import("methods")
+import("distr")
+import("distrEx")
+import("RandVar")
+import("distrMod")
+import("RobAStBase")
+import("ROptEst")
+
+exportClasses("RegTypeFamily",
+ "L2RegTypeFamily")
+exportClasses("CondNeighborhood",
+ "CondContNeighborhood",
+ "CondTotalVarNeighborhood",
+ "AvCondNeighborhood",
+ "Av1CondNeighborhood",
+ "Av2CondNeighborhood",
+ "Av1CondContNeighborhood",
+ "Av1CondTotalVarNeighborhood",
+ "Av2CondContNeighborhood")
+exportClasses("FixRobRegTypeModel",
+ "InfRobRegTypeModel")
+exportClasses("CondIC",
+ "CondContIC",
+ "Av1CondContIC",
+ "Av2CondContIC",
+ "CondTotalVarIC",
+ "Av1CondTotalVarIC")
+
+exportMethods("show",
+ "plot",
+ "E")
+exportMethods("ErrorDistr",
+ "ErrorSymm",
+ "RegDistr",
+ "RegSymm",
+ "Regressor",
+ "L2deriv",
+ "ErrorL2deriv",
+ "ErrorL2derivSymm",
+ "ErrorL2derivDistr",
+ "ErrorL2derivDistrSymm",
+ "FisherInfo",
+ "checkL2deriv")
+exportMethods("radiusCurve",
+ "neighbor", "neighbor<-",
+ "bound",
+ "Curve",
+ "CallL2Fam", "CallL2Fam<-",
+ "generateIC",
+ "checkIC",
+ "clip", "clip<-",
+ "cent", "cent<-",
+ "stand", "stand<-",
+ "lowerCase", "lowerCase<-",
+ "neighborRadius", "neighborRadius<-",
+ "neighborRadiusCurve", "neighborRadiusCurve<-",
+ "clipLo", "clipLo<-",
+ "clipUp", "clipUp<-")
+exportMethods("optIC",
+ "getInfRobRegTypeIC",
+ "getFixRobRegTypeIC",
+ "getAsRiskRegTS",
+ "getFiRiskRegTS",
+ "getInfClipRegTS",
+ "getFixClipRegTS",
+ "getInfGammaRegTS",
+ "getInfCentRegTS",
+ "getInfStandRegTS",
+ "getRiskIC",
+ "optRisk",
+ "radiusMinimaxIC",
+ "getIneffDiff",
+ "leastFavorableRadius")
+
+export("RegTypeFamily",
+ "L2RegTypeFamily",
+ "NormLinRegFamily",
+ "NormLinRegScaleFamily",
+ "NormLinRegInterceptFamily")
+export("CondContNeighborhood",
+ "CondTotalVarNeighborhood",
+ "Av1CondContNeighborhood",
+ "Av1CondTotalVarNeighborhood",
+ "Av2CondContNeighborhood")
+export("FixRobRegTypeModel",
+ "InfRobRegTypeModel")
+export("CondIC",
+ "CondContIC",
+ "Av1CondContIC",
+ "Av2CondContIC",
+ "CondTotalVarIC",
+ "Av1CondTotalVarIC")
Added: branches/robast-0.9/pkg/ROptReg/R/AllClass.R
===================================================================
--- branches/robast-0.9/pkg/ROptReg/R/AllClass.R (rev 0)
+++ branches/robast-0.9/pkg/ROptReg/R/AllClass.R 2012-01-31 12:15:29 UTC (rev 459)
@@ -0,0 +1,463 @@
+.onLoad <- function(lib, pkg){
+ require("methods", character = TRUE, quietly = TRUE)
+ require("distr", character = TRUE, quietly = TRUE)
+ require("distrEx", character = TRUE, quietly = TRUE)
+ require("RandVar", character = TRUE, quietly = TRUE)
+ require("ROptEstOld", character = TRUE, quietly = TRUE)
+}
+
+# Regression type families
+setClass("RegTypeFamily",
+ representation(ErrorDistr = "Distribution",
+ ErrorSymm = "DistributionSymmetry",
+ RegDistr = "Distribution",
+ RegSymm = "DistributionSymmetry",
+ Regressor = "EuclRandVariable"),
+ prototype(name = "regression type family",
+ distribution = LMCondDistribution(),
+ distrSymm = new("NoSymmetry"),
+ ErrorDistr = Norm(),
+ ErrorSymm = new("NoSymmetry"),
+ RegDistr = Norm(),
+ RegSymm = new("NoSymmetry"),
+ Regressor = RealRandVariable(Map = list(function(x){x}), Domain = Reals()),
+ param = new("ParamFamParameter", main = 0, trafo = matrix(1)),
+ props = character(0)),
+ contains = "ParamFamily",
+ validity = function(object){
+ if(!is(object at distribution, "UnivariateCondDistribution"))
+ stop("distribution has to be of class 'UnivariateCondDistribution'")
+ if(length(object at Regressor) != 1)
+ stop("'Regressor' has to be of length 1")
+ if(is(object at ErrorDistr, "UnivariateCondDistribution"))
+ stop("'ErrorDistr' has to be an unconditional distribution")
+ if(is(object at RegDistr, "UnivariateCondDistribution"))
+ stop("'RegrDistr' has to be an unconditional distribution")
+ if(dimension(Domain(object at Regressor)) != dimension(img(object at RegDistr)))
+ stop("dimension of 'Domain' of 'Regressor' has to be identical to",
+ "dimension of 'img' of 'RegDistr'")
+ })
+# L2 differentiable regression type model
+setClass("L2RegTypeFamily",
+ representation(L2deriv = "EuclRandVarList",
+ ErrorL2deriv = "EuclRandVarList",
+ ErrorL2derivSymm = "FunSymmList",
+ ErrorL2derivDistr = "DistrList",
+ ErrorL2derivDistrSymm = "DistrSymmList",
+ FisherInfo = "PosDefSymmMatrix"),
+ prototype(name = "L2 differentiable regression type family",
+ distribution = LMCondDistribution(),
+ distrSymm = new("NoSymmetry"),
+ ErrorDistr = Norm(),
+ ErrorSymm = new("NoSymmetry"),
+ RegDistr = Norm(),
+ RegSymm = new("NoSymmetry"),
+ Regressor = RealRandVariable(Map = list(function(x){x}), Domain = Reals()),
+ param = new("ParamFamParameter", main = 0, trafo = matrix(1)),
+ props = character(0),
+ L2deriv = EuclRandVarList(RealRandVariable(Map = list(function(x){x[1]*x[2]}),
+ Domain = EuclideanSpace(dimension=2))),
+ ErrorL2deriv = EuclRandVarList(RealRandVariable(Map = list(function(x){x}), Domain = Reals())),
+ ErrorL2derivSymm = new("FunSymmList"),
+ ErrorL2derivDistr = UnivarDistrList(Norm()),
+ ErrorL2derivDistrSymm = new("DistrSymmList"),
+ FisherInfo = new("PosDefSymmMatrix", matrix(1))),
+ contains = "RegTypeFamily",
+ validity = function(object){
+ if(dimension(Domain(object at ErrorL2deriv[[1]])) != dimension(img(object at ErrorDistr)))
+ stop("dimension of 'Domain' of 'ErrorL2deriv' != ",
+ "dimension of 'img' of 'ErrorDistr'")
+ if(dimension(Domain(object at L2deriv[[1]])) != (dimension(img(object at ErrorDistr))
+ + dimension(img(object at RegDistr))))
+ stop("'Domain' of 'L2deriv' has wrong dimension")
+
+ dims <- length(object at param)
+ if(ncol(object at FisherInfo) != dims)
+ stop(paste("dimension of 'FisherInfo' should be", dims))
+
+ nrvalues <- numberOfMaps(object at ErrorL2deriv)
+ if(nrvalues != length(object at ErrorL2derivSymm))
+ stop("number of Maps of 'ErrorL2deriv' != length of 'ErrorL2derivSymm'")
+ if(nrvalues != length(object at ErrorL2derivDistr))
+ stop("number of Maps of 'ErrorL2deriv' != length of 'ErrorL2derivDistr'")
+ if(nrvalues != length(object at ErrorL2derivDistrSymm))
+ stop("number of Maps of 'ErrorL2deriv' != length of 'ErrorL2derivDistrSymm'")
+ if(dimension(Domain(object at ErrorL2deriv[[1]])) != dimension(img(object at ErrorDistr)))
+ stop("dimension of 'Domain' of 'L2deriv' != dimension of 'img' of 'ErrorDistr'")
+ if(dimension(object at L2deriv) != dims)
+ stop("dimension of 'L2deriv' != dimension of parameters")
+
+ return(TRUE)
+ })
+# conditional (error-free-variables) neighborhood
+setClass("CondNeighborhood",
+ representation(radiusCurve = "function"),
+ contains = c("Neighborhood", "VIRTUAL"),
+ validity = function(object){
+ if(length(formals(object at radiusCurve)) != 1)
+ stop("'radiusCurve' has to be a function of one argument")
+ if(names(formals(object at radiusCurve)) != "x")
+ stop("'radiusCurve' has to be a function with argument name = 'x'")
+ })
+# conditional convex contamination neighborhood
+setClass("CondContNeighborhood",
+ prototype = prototype(type = "conditional convex contamination neighborhood",
+ radius = 0,
+ radiusCurve = function(x){1}),
+ contains = "CondNeighborhood")
+# conditional total variaton neighborhood
+setClass("CondTotalVarNeighborhood",
+ prototype = prototype(type = "conditional total variation neighborhood",
+ radius = 0,
+ radiusCurve = function(x){1}),
+ contains = "CondNeighborhood")
+# average conditional neighborhood
+setClass("AvCondNeighborhood", representation(exponent = "numeric"),
+ contains = c("CondNeighborhood", "VIRTUAL"))
+# average conditional neighborhood (exponent = 1)
+setClass("Av1CondNeighborhood",
+ contains = c("AvCondNeighborhood", "VIRTUAL"),
+ validity = function(object){
+ if(object at exponent != 1)
+ stop("exponent has to be 1")
+ })
+# average conditional convex contamination neighborhood (exponent = 1)
+setClass("Av1CondContNeighborhood",
+ prototype = prototype(type = "average conditional convex contamination neighborhood",
+ radius = 0,
+ radiusCurve = function(x){1},
+ exponent = 1),
+ contains = c("Av1CondNeighborhood"))
+# average conditional total variation neighborhood (exponent = 1)
+setClass("Av1CondTotalVarNeighborhood",
+ prototype = prototype(type = "average conditional total variation neighborhood",
+ radius = 0,
+ radiusCurve = function(x){1},
+ exponent = 1),
+ contains = c("Av1CondNeighborhood"))
+# average square conditional neighborhood (exponent = 2)
+setClass("Av2CondNeighborhood",
+ contains = c("AvCondNeighborhood", "VIRTUAL"),
+ validity = function(object){
+ if(object at exponent != 2)
+ stop("exponent has to be 2")
+ })
+# average square conditional convex contamination neighborhood (exponent = 2)
+setClass("Av2CondContNeighborhood",
+ prototype = prototype(type = "average square conditional convex contamination neighborhood",
+ radius = 0,
+ radiusCurve = function(x){1},
+ exponent = 2),
+ contains = c("Av2CondNeighborhood"))
+# robust regression-type model with fixed
+# (conditional or unconditional) neighborhood
+setClass("FixRobRegTypeModel",
+ prototype = prototype(center = new("RegTypeFamily"),
+ neighbor = new("ContNeighborhood")),
+ contains = "RobModel",
+ validity = function(object){
+ if(!is(object at center, "RegTypeFamily"))
+ stop("center has to be a regression type family")
+ if(any(object at neighbor@radius < 0 || object at neighbor@radius > 1))
+ stop("neighborhood radius has to be in [0, 1]")
+ if(is(object at neighbor, "CondNeighborhood")){
+ D1 <- object at center@RegDistr
+ radCurve <- object at neighbor@radiusCurve
+ if(is(D1, "UnivariateDistribution")){
+ if(is(D1, "AbscontDistribution")){
+ xlo <- ifelse(is.finite(q(D1)(0)), q(D1)(0), q(D1)(distr::TruncQuantile))
+ xup <- ifelse(is.finite(q(D1)(1)), q(D1)(1), q(D1)(1 - distr::TruncQuantile))
+ x <- seq(from = xlo, to = xup, by = 1e-3)
+ }else{
+ if(is(Regressor, "DiscreteDistribution"))
+ x <- support(D1)
+ else
+ x <- unique(r(D1)(1e5))
+ }
+ if(length(radCurve(x[1])) != 1)
+ stop("'radiusCurve' has to be a real-valued function")
+ }else{
+ if(is(D1, "DiscreteMVDistribution"))
+ x <- support(D1)
+ else
+ x <- r(D1)(1e5)
+ if(length(radCurve(x[1,])) != 1)
+ stop("'radiusCurve' has to be a real-valued function")
+ }
+ if(min(radCurve(x)) < 0 || max(radCurve(x)) > 1)
+ stop("'radiusCurve' has to be a non-negative function",
+ " with values in [0,1]")
+ if(!is.finite(E(D1, radCurve)))
+ stop("'radiusCurve' has an infinite integral")
+ if(is(object at neighbor, "AvCondNeighborhood")){
+ alpha <- object at neighbor@exponent
+ radCurve1 <- function(x, radCurve, alpha){ radCurve(x)^alpha }
+ constr <- E(D1, radCurve1, radCurve = radCurve, alpha = alpha)^(1/alpha)
+ if(constr > 1+.Machine$double.eps^0.5)
+ stop("'radiusCurve' does not fulfill the norm constraint")
+ }
+ }
+ return(TRUE)
+ })
+# robust regression-type model with infinitesimal
+# (conditional or unconditional) neighborhood
+setClass("InfRobRegTypeModel",
+ prototype = prototype(center = new("L2RegTypeFamily"),
+ neighbor = new("ContNeighborhood")),
+ contains = "RobModel",
+ validity = function(object){
+ if(!is(object at center, "L2RegTypeFamily"))
+ stop("'center' is no 'L2RegTypeFamily'")
+ if(any(object at neighbor@radius < 0)) # radius vector?!
+ stop("'radius' has to be in [0, Inf]")
+ if(is(object at neighbor, "CondNeighborhood")){
+ D1 <- object at center@RegDistr
+ radCurve <- object at neighbor@radiusCurve
+ if(is(D1, "UnivariateDistribution")){
+ if(is(D1, "AbscontDistribution")){
+ xlo <- ifelse(is.finite(q(D1)(0)), q(D1)(0), q(D1)(distr::TruncQuantile))
+ xup <- ifelse(is.finite(q(D1)(1)), q(D1)(1), q(D1)(1 - distr::TruncQuantile))
+ x <- seq(from = xlo, to = xup, by = 1e-3)
+ }else{
+ if(is(Regressor, "DiscreteDistribution"))
+ x <- support(D1)
+ else
+ x <- unique(r(D1)(1e5))
+ }
+ if(length(radCurve(x[1])) != 1)
+ stop("'radiusCurve' has to be a real-valued function")
+ }else{
+ if(is(D1, "DiscreteMVDistribution"))
+ x <- support(D1)
+ else
+ x <- r(D1)(1e5)
+ if(length(radCurve(x[1,])) != 1)
+ stop("'radiusCurve' has to be a real-valued function")
+ }
+ if(min(radCurve(x)) < 0)
+ stop("'radiusCurve' has to be a non-negative function")
+ if(!is.finite(E(D1, radCurve)))
+ stop("'radiusCurve' has an infinite integral")
+ if(is(object at neighbor, "AvCondNeighborhood")){
+ alpha <- object at neighbor@exponent
+ radCurve1 <- function(x, radCurve, alpha){ radCurve(x)^alpha }
+ constr <- E(D1, radCurve1, radCurve = radCurve, alpha = alpha)^(1/alpha)
+ if(constr > 1+.Machine$double.eps^0.5)
+ stop("'radiusCurve' does not fulfill the norm constraint")
+ }
+ }else
+ return(TRUE)
+ })
+# square integrable, conditionally centered (partial) IC
+setClass("CondIC",
+ prototype = prototype(name = "square integrable, conditionally centered (partial) IC",
+ Curve = EuclRandVarList(EuclRandVariable(Map = list(function(x){x[1]*x[2]}),
+ Domain = EuclideanSpace(dimension=2), Range = Reals())),
+ Risks = list(),
+ Infos = matrix(c(character(0),character(0)), ncol=2,
+ dimnames=list(character(0), c("method", "message"))),
+ CallL2Fam = call("L2RegTypeFamily")),
+ contains = "IC",
+ validity = function(object){
+ L2Fam <- eval(object at CallL2Fam)
+ if(!is(L2Fam, "L2RegTypeFamily"))
+ stop("'CallL2Fam' has to generate an object of class 'L2RegTypeFamily'")
+
+ return(TRUE)
+ })
+# square integrable, conditionally centered (partial) IC
+# of contamination type
+setClass("CondContIC",
+ representation(clip = "RealRandVariable",
+ cent = "EuclRandVarList",
+ stand = "matrix",
+ lowerCase = "OptionalNumeric",
+ neighborRadius = "numeric",
+ neighborRadiusCurve = "function"),
+ prototype(name = "conditionally centered IC for average conditional contamination neighborhoods",
+ Curve = EuclRandVarList(RealRandVariable(Map = list(function(x){x[1]*x[2]}),
+ Domain = EuclideanSpace(dimension = 2))),
+ Risks = list(),
+ Infos = matrix(c(character(0),character(0)), ncol=2,
+ dimnames=list(character(0), c("method", "message"))),
+ CallL2Fam = call("L2RegTypeFamily"),
+ clip = RealRandVariable(Map = list(function(x){ Inf }),
+ Domain = EuclideanSpace(dimension = 1)),
+ cent = EuclRandVarList(RealRandVariable(Map = list(function(x){numeric(length(x))}),
+ Domain = EuclideanSpace(dimension = 2))),
+ stand = as.matrix(1),
+ lowerCase = NULL,
+ neighborRadius = 0,
+ neighborRadiusCurve = function(x){1}),
+ contains = "CondIC",
+ validity = function(object){
+ if(any(object at neighborRadius < 0)) # radius vector?!
+ stop("'neighborRadius' has to be in [0, Inf]")
+ if(length(formals(object at neighborRadiusCurve)) != 1)
+ stop("'neighborRadiusCurve' has to be a function of one argument")
+ if(names(formals(object at neighborRadiusCurve)) != "x")
+ stop("'neighborRadiusCurve' has to be a function with argument name = 'x'")
+ if(dimension(object at cent) != nrow(object at stand))
+ stop("dimension of centering function != nrow of standardizing matrix")
+ if(dimension(object at clip) != 1)
+ stop("dimension of clipping function has to be 1")
+ if(!is.null(object at lowerCase))
+ if(length(object at lowerCase) != nrow(object at stand))
+ stop("length of 'lowerCase' != nrow of standardizing matrix")
+ L2Fam <- eval(object at CallL2Fam)
+ if(!identical(dim(L2Fam at param@trafo), dim(object at stand)))
+ stop("dimension of 'trafo' of 'param' != dimension of 'stand'")
+
+ return(TRUE)
+ })
+# square integrable, conditionally centered (partial) IC
+# of contamination type
+setClass("Av1CondContIC",
+ representation(clip = "numeric",
+ cent = "EuclRandVarList",
+ stand = "matrix",
+ lowerCase = "OptionalNumeric",
+ neighborRadius = "numeric"),
+ prototype(name = "conditionally centered IC for average conditional contamination neighborhoods",
+ Curve = EuclRandVarList(RealRandVariable(Map = list(function(x){x[1]*x[2]}),
+ Domain = EuclideanSpace(dimension = 2))),
+ Risks = list(),
+ Infos = matrix(c(character(0),character(0)), ncol=2,
+ dimnames=list(character(0), c("method", "message"))),
+ CallL2Fam = call("L2RegTypeFamily"),
+ clip = Inf,
+ cent = EuclRandVarList(RealRandVariable(Map = list(function(x){numeric(length(x))}),
+ Domain = EuclideanSpace(dimension = 2))),
+ stand = as.matrix(1),
+ lowerCase = NULL,
+ neighborRadius = 0),
+ contains = "CondIC",
+ validity = function(object){
+ if(any(object at neighborRadius < 0)) # radius vector?!
+ stop("'neighborRadius' has to be in [0, Inf]")
+ if(dimension(object at cent) != nrow(object at stand))
+ stop("dimension of centering function != nrow of standardizing matrix")
+ if(length(object at clip) != 1)
+ stop("length of clipping bound has to be 1")
+ if(!is.null(object at lowerCase))
+ if(length(object at lowerCase) != nrow(object at stand))
+ stop("length of 'lowerCase' != nrow of standardizing matrix")
+ L2Fam <- eval(object at CallL2Fam)
+ if(!identical(dim(L2Fam at param@trafo), dim(object at stand)))
+ stop("dimension of 'trafo' of 'param' != dimension of 'stand'")
+
+ return(TRUE)
+ })
+# square integrable, conditionally centered (partial) IC
+# of contamination type
+setClass("Av2CondContIC",
+ representation(clip = "numeric",
+ cent = "numeric",
+ stand = "numeric",
+ lowerCase = "OptionalNumeric",
+ neighborRadius = "numeric"),
+ prototype(name = "conditionally centered IC for average square conditional contamination neighborhoods",
+ Curve = EuclRandVarList(RealRandVariable(Map = list(function(x){x[1]*x[2]}),
+ Domain = EuclideanSpace(dimension = 2))),
+ Risks = list(),
+ Infos = matrix(c(character(0),character(0)), ncol=2,
+ dimnames=list(character(0), c("method", "message"))),
+ CallL2Fam = call("L2RegTypeFamily"),
+ clip = Inf,
+ cent = 0,
+ stand = 1,
+ lowerCase = NULL,
+ neighborRadius = 0),
+ contains = "CondIC",
+ validity = function(object){
+ if(any(object at neighborRadius < 0)) # radius vector?!
+ stop("'neighborRadius' has to be in [0, Inf]")
+ if(length(object at cent) != 1)
+ stop("length of 'cent' has to be 1")
+ if(length(object at stand) != 1)
+ stop("length of 'stand' has to be 1")
+ if(length(object at clip) != 1)
+ stop("length of clipping bound has to be 1")
+ if(!is.null(object at lowerCase))
+ if(length(object at lowerCase) != 1)
+ stop("length of 'lowerCase' has to be 1")
+
+ return(TRUE)
+ })
+# square integrable, conditionally centered (partial) IC
+# of total variation type
+setClass("CondTotalVarIC",
+ representation(clipUp = "RealRandVariable",
+ clipLo = "RealRandVariable",
+ stand = "matrix",
+ lowerCase = "OptionalNumeric",
+ neighborRadius = "numeric",
+ neighborRadiusCurve = "function"),
+ prototype(name = "conditionally centered IC for average conditional contamination neighborhoods",
+ Curve = EuclRandVarList(RealRandVariable(Map = list(function(x){x[1]*x[2]}),
+ Domain = EuclideanSpace(dimension = 2))),
+ Risks = list(),
+ Infos = matrix(c(character(0),character(0)), ncol=2,
+ dimnames=list(character(0), c("method", "message"))),
+ CallL2Fam = call("L2RegTypeFamily"),
+ clipUp = RealRandVariable(Map = list(function(x){ Inf }),
+ Domain = EuclideanSpace(dimension = 1)),
+ clipLo = RealRandVariable(Map = list(function(x){ -Inf }),
+ Domain = EuclideanSpace(dimension = 1)),
+ stand = as.matrix(1),
+ lowerCase = NULL,
+ neighborRadius = 0,
+ neighborRadiusCurve = function(x){1}),
+ contains = "CondIC",
+ validity = function(object){
+ if(any(object at neighborRadius < 0)) # radius vector?!
+ stop("'neighborRadius' has to be in [0, Inf]")
+ if(length(formals(object at neighborRadiusCurve)) != 1)
+ stop("'neighborRadiusCurve' has to be a function of one argument")
+ if(names(formals(object at neighborRadiusCurve)) != "x")
+ stop("'neighborRadiusCurve' has to be a function with argument name = 'x'")
+ if(dimension(object at clipLo) != 1)
+ stop("dimension of lower clipping function has to be 1")
+ if(dimension(object at clipUp) != 1)
+ stop("dimension of upper clipping function has to be 1")
+ L2Fam <- eval(object at CallL2Fam)
+ if(!identical(dim(L2Fam at param@trafo), dim(object at stand)))
+ stop("dimension of 'trafo' of 'param' != dimension of 'stand'")
+
+ return(TRUE)
+ })
+# square integrable, conditionally centered (partial) IC
+# of total variation type
+setClass("Av1CondTotalVarIC",
+ representation(clipUp = "numeric",
+ clipLo = "RealRandVariable",
+ stand = "matrix",
+ lowerCase = "OptionalNumeric",
+ neighborRadius = "numeric"),
+ prototype(name = "conditionally centered IC for average conditional contamination neighborhoods",
+ Curve = EuclRandVarList(RealRandVariable(Map = list(function(x){x[1]*x[2]}),
+ Domain = EuclideanSpace(dimension = 2))),
+ Risks = list(),
+ Infos = matrix(c(character(0),character(0)), ncol=2,
+ dimnames=list(character(0), c("method", "message"))),
+ CallL2Fam = call("L2RegTypeFamily"),
+ clipUp = Inf,
+ clipLo = RealRandVariable(Map = list(function(x){ -Inf }),
+ Domain = EuclideanSpace(dimension = 1)),
+ stand = as.matrix(1),
+ lowerCase = NULL,
+ neighborRadius = 0),
+ contains = "CondIC",
+ validity = function(object){
+ if(any(object at neighborRadius < 0)) # radius vector?!
+ stop("'neighborRadius' has to be in [0, Inf]")
+ if(dimension(object at clipLo) != 1)
+ stop("dimension of lower clipping function has to be 1")
+ if(length(object at clipUp) != 1)
+ stop("length of upper clipping bound has to be 1")
+ L2Fam <- eval(object at CallL2Fam)
+ if(!identical(dim(L2Fam at param@trafo), dim(object at stand)))
+ stop("dimension of 'trafo' of 'param' != dimension of 'stand'")
+
+ return(TRUE)
+ })
Added: branches/robast-0.9/pkg/ROptReg/R/AllGeneric.R
===================================================================
--- branches/robast-0.9/pkg/ROptReg/R/AllGeneric.R (rev 0)
+++ branches/robast-0.9/pkg/ROptReg/R/AllGeneric.R 2012-01-31 12:15:29 UTC (rev 459)
@@ -0,0 +1,72 @@
+if(!isGeneric("ErrorDistr")){
+ setGeneric("ErrorDistr", function(object) standardGeneric("ErrorDistr"))
+}
+if(!isGeneric("ErrorSymm")){
+ setGeneric("ErrorSymm", function(object) standardGeneric("ErrorSymm"))
+}
+if(!isGeneric("RegDistr")){
+ setGeneric("RegDistr", function(object) standardGeneric("RegDistr"))
+}
+if(!isGeneric("RegSymm")){
+ setGeneric("RegSymm", function(object) standardGeneric("RegSymm"))
+}
+if(!isGeneric("Regressor")){
+ setGeneric("Regressor", function(object) standardGeneric("Regressor"))
+}
+if(!isGeneric("ErrorL2deriv")){
+ setGeneric("ErrorL2deriv", function(object) standardGeneric("ErrorL2deriv"))
+}
+if(!isGeneric("ErrorL2derivSymm")){
+ setGeneric("ErrorL2derivSymm", function(object) standardGeneric("ErrorL2derivSymm"))
+}
+if(!isGeneric("ErrorL2derivDistr")){
+ setGeneric("ErrorL2derivDistr", function(object) standardGeneric("ErrorL2derivDistr"))
+}
+if(!isGeneric("ErrorL2derivDistrSymm")){
+ setGeneric("ErrorL2derivDistrSymm", function(object) standardGeneric("ErrorL2derivDistrSymm"))
+}
+if(!isGeneric("radiusCurve")){
+ setGeneric("radiusCurve", function(object) standardGeneric("radiusCurve"))
+}
+if(!isGeneric("neighborRadiusCurve")){
+ setGeneric("neighborRadiusCurve", function(object) standardGeneric("neighborRadiusCurve"))
+}
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/robast -r 459
More information about the Robast-commits
mailing list