[Robast-commits] r1116 - in branches/robast-1.2/pkg: . 20080808RobAStBaseDeadEnd
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Aug 10 01:54:33 CEST 2018
Author: ruckdeschel
Date: 2018-08-10 01:54:33 +0200 (Fri, 10 Aug 2018)
New Revision: 1116
Added:
branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/
branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/AllClass.R
branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/AllGeneric.R
branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/ContIC.R
branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/HampIC.R
branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/IC.R
branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/TotalVarIC.R
branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/combinedICs.R
branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/ddPlot_utils.R
branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/generateICfct.R
branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/kStepEstimator.R
Log:
Added: branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/AllClass.R
===================================================================
--- branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/AllClass.R (rev 0)
+++ branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/AllClass.R 2018-08-09 23:54:33 UTC (rev 1116)
@@ -0,0 +1,343 @@
+.onLoad <- function(lib, pkg){
+# require("methods", character = TRUE, quietly = TRUE)
+# require("distr", character = TRUE, quietly = TRUE)
+# require("distrEx", character = TRUE, quietly = TRUE)
+# require("distrMod", character = TRUE, quietly = TRUE)
+# require("RandVar", character = TRUE, quietly = TRUE)
+}
+
+.onAttach <- function(library, pkg){
+ unlockBinding(".RobAStBaseOptions", asNamespace("RobAStBase"))
+ msga <- gettext(
+ "Some functions from pkg's 'stats' and 'graphics' are intentionally masked ---see RobAStBaseMASK().\n"
+ )
+ msgb <- gettext(
+ "Note that global options are controlled by RobAStBaseoptions() ---c.f. ?\"RobAStBaseoptions\"."
+ )
+ buildStartupMessage(pkg = "RobAStBase", msga, msgb,
+ library = library, packageHelp = TRUE
+ # , MANUAL="http://www.uni-bayreuth.de/departments/math/org/mathe7/DISTR/distr.pdf"
+ # , VIGNETTE = gettext("Package \"distrDoc\" provides a vignette to this package as well as to several related packages; try vignette(\"distr\").")
+ )
+ invisible()
+}
+
+RobAStBaseMASK <- function(library = NULL)
+{
+ infoShow(pkg = "RobAStBase", filename = "MASKING", library = library)
+}
+
+## neighborhood
+setClass("Neighborhood",
+ representation(type = "character",
+ radius = "numeric"),
+ contains = "VIRTUAL")
+## unconditional (errors-in-variables) neighborhood
+setClass("UncondNeighborhood", contains = c("Neighborhood", "VIRTUAL"))
+## unconditional convex contamination neighborhood
+setClass("ContNeighborhood", contains = "UncondNeighborhood",
+ prototype = prototype(type = "(uncond.) convex contamination neighborhood",
+ radius = 0))
+## unconditional total variation neighborhood
+setClass("TotalVarNeighborhood", contains = "UncondNeighborhood",
+ prototype = prototype(type = "(uncond.) total variation neighborhood",
+ radius = 0))
+## robust model
+setClass("RobModel",
+ representation(center = "ProbFamily",
+ neighbor = "Neighborhood"),
+ contains = "VIRTUAL")
+## robust model with fixed (unconditional) neighborhood
+setClass("FixRobModel",
+ prototype = prototype(center = new("ParamFamily"),
+ neighbor = new("ContNeighborhood")),
+ contains = "RobModel",
+ validity = function(object){
+ if(!is(object at neighbor, "UncondNeighborhood"))
+ stop("'neighbor' is no unconditional neighborhood")
+ if(any(object at neighbor@radius < 0 || object at neighbor@radius > 1))
+ stop("neighborhood radius has to be in [0, 1]")
+ else return(TRUE)
+ })
+## robust model with infinitesimal (unconditional) neighborhood
+setClass("InfRobModel",
+ prototype = prototype(center = new("L2ParamFamily"),
+ neighbor = new("ContNeighborhood")),
+ contains = "RobModel",
+ validity = function(object){
+ if(!is(object at neighbor, "UncondNeighborhood"))
+ stop("'neighbor' is no unconditional neighborhood")
+ if(any(object at neighbor@radius < 0))
+ stop("'radius' has to be in [0, Inf]")
+ else return(TRUE)
+ })
+## Weights
+setClass("RobAStControl", representation(name ="character"),
+ contains = "VIRTUAL")
+
+setClass("RobWeight", representation(name = "character", weight = "function"),
+ prototype(name = "some weight", weight = function(x) 1))
+setClass("BoundedWeight", representation(clip = "numeric"),
+ prototype(clip = 1), contains = "RobWeight")
+setClass("BdStWeight", representation(stand = "matrix"),
+ prototype(stand = matrix(1)), contains = "BoundedWeight")
+setClass("HampelWeight", representation(cent = "numeric"),
+ prototype(cent = 0), contains = "BdStWeight")
+
+
+
+
+## Influence curve/function with domain: EuclideanSpace
+setClass("InfluenceCurve",
+ representation(name = "character",
+ Curve = "EuclRandVarList",
+ Risks = "list",
+ Infos = "matrix"),
+ validity = function(object){
+ if(!is(Domain(object at Curve[[1]]), "EuclideanSpace"))
+ stop("The domain of 'Curve' has to be a Euclidean space")
+ if(!is.character(object at Infos))
+ stop("'Infos' contains no matrix of characters")
+ for(char in names(object at Risks))
+ if(!extends(char, "RiskType"))
+ stop(paste(char, "is no valid 'RiskType'"))
+ if(ncol(object at Infos)!=2)
+ stop("'Infos' must have two columns")
+ else TRUE
+ })
+## partial incluence curve
+setClass("IC", representation(CallL2Fam = "call",
+ modifyIC = "OptionalFunction"),
+ prototype(name = "square integrable (partial) influence curve",
+ Curve = EuclRandVarList(RealRandVariable(Map = list(function(x){x}),
+ Domain = Reals())),
+ Risks = list(),
+ Infos = matrix(c(character(0),character(0)), ncol=2,
+ dimnames=list(character(0), c("method", "message"))),
+ CallL2Fam = call("L2ParamFamily"),
+ modifyIC = NULL),
+ contains = "InfluenceCurve",
+ validity = function(object){
+ L2Fam <- eval(object at CallL2Fam)
+ trafo <- trafo(L2Fam at param)
+ if(nrow(trafo) != dimension(object at Curve))
+ stop("wrong dimension of 'Curve'")
+ if(dimension(Domain(L2Fam at L2deriv[[1]])) != dimension(Domain(object at Curve[[1]])))
+ stop("dimension of 'Domain' of 'L2deriv' != dimension of 'Domain' of 'Curve'")
+
+ return(TRUE)
+ })
+
+## internal class
+setClass(".fastIC", representation(.fastFct = "OptionalFunction"),
+ prototype(.fastFct = NULL), contains="IC")
+
+## HampIC -- common mother class to ContIC and TotalVarIC
+setClass("HampIC",
+ representation(stand = "matrix",
+ lowerCase = "OptionalNumeric",
+ neighborRadius = "numeric",
+ weight = "RobWeight",
+ biastype = "BiasType",
+ normtype = "NormType"),
+ prototype(name = "IC of total-var or contamination type",
+ Curve = EuclRandVarList(RealRandVariable(Map = list(function(x){x}),
+ Domain = Reals())),
+ Risks = list(), weight = new("RobWeight"),
+ Infos = matrix(c(character(0),character(0)), ncol=2,
+ dimnames=list(character(0), c("method", "message"))),
+ CallL2Fam = call("L2ParamFamily"),
+ modifyIC = NULL,
+ stand = as.matrix(1),
+ lowerCase = NULL,
+ neighborRadius = 0,
+ biastype = symmetricBias(),
+ NormType = NormType()),
+ contains = ".fastIC",
+ validity = function(object){
+ if(any(object at neighborRadius < 0)) # radius vector?!
+ stop("'neighborRadius' has to be in [0, Inf]")
+ 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(trafo(L2Fam at param)), dim(object at stand)))
+ stop(paste("dimension of 'trafo' of 'param' != dimension of 'stand'"))
+ return(TRUE)
+ })
+## (partial) influence curve of contamination type
+setClass("ContIC",
+ representation(clip = "numeric",
+ cent = "numeric"),
+ prototype(name = "IC of contamination type",
+ Curve = EuclRandVarList(RealRandVariable(Map = list(function(x){x}),
+ Domain = Reals())),
+ Risks = list(),
+ Infos = matrix(c(character(0),character(0)), ncol=2,
+ dimnames=list(character(0), c("method", "message"))),
+ CallL2Fam = call("L2ParamFamily"),
+ modifyIC = NULL,
+ clip = Inf, cent = 0, stand = as.matrix(1),
+ lowerCase = NULL,
+ neighborRadius = 0, weight = new("HampelWeight"),
+ biastype = symmetricBias(), NormType = NormType()),
+ contains = "HampIC",
+ validity = function(object){
+ if(length(object at cent) != nrow(object at stand))
+ stop("length of centering constant != nrow of standardizing matrix")
+ if((length(object at clip) != 1) && (length(object at clip) != length(object at Curve)))
+ stop("length of clipping bound != 1 and != length of 'Curve'")
+ if(!is(weight,"HampelWeight"))
+ stop("Weight has to be of class 'HampelWeight'")
+ return(TRUE)
+ })
+## (partial) influence curve of total variation type
+setClass("TotalVarIC",
+ representation(clipLo = "numeric",
+ clipUp = "numeric"),
+ prototype(name = "IC of total variation type",
+ Curve = EuclRandVarList(RealRandVariable(Map = list(function(x){x}),
+ Domain = Reals())),
+ Risks = list(),
+ Infos = matrix(c(character(0),character(0)), ncol=2,
+ dimnames=list(character(0), c("method", "message"))),
+ CallL2Fam = call("L2ParamFamily"),
+ modifyIC = NULL,
+ clipLo = -Inf, clipUp = Inf, stand = as.matrix(1),
+ lowerCase = NULL,
+ neighborRadius = 0, weight = new("BdStWeight"),
+ biastype = symmetricBias(), NormType = NormType()),
+ contains = "HampIC",
+ validity = function(object){
+ if((length(object at clipLo) != 1) && (length(object at clipLo) != length(object at Curve)))
+ stop("length of lower clipping bound != 1 and != length of 'Curve'")
+ if((length(object at clipLo) != 1) && (length(object at clipLo) != length(object at Curve)))
+ stop("length of upper clipping bound != 1 and != length of 'Curve'")
+ if(!is(weight,"BdStWeight"))
+ stop("Weight has to be of class 'BdStWeight'")
+ return(TRUE)
+ })
+
+## ALEstimate
+setClassUnion("OptionalCall", c("call","NULL"))
+setClassUnion("OptionalInfluenceCurve", c("InfluenceCurve", "NULL"))
+setClassUnion("OptionalInfluenceCurveOrCall", c("InfluenceCurve", "NULL", "call"))
+setClassUnion("StartClass", c("numeric", "matrix", "function", "Estimate"))
+setClass("pICList",
+ prototype = prototype(list()),
+ contains = "list",
+ validity = function(object){
+ nrvalues <- length(object)
+ if(nrvalues){
+ for(i in 1:nrvalues)
+ if(!is(object[[i]], "OptionalInfluenceCurve"))
+ stop("element ", i, " is no 'OptionalInfluenceCurve'")
+ }
+ return(TRUE)
+ })
+setClassUnion("OptionalpICList", c("pICList", "NULL"))
+setClass("ALEstimate",
+ representation(pIC = "OptionalInfluenceCurveOrCall", #"OptionalInfluenceCurve",
+ asbias = "OptionalNumeric"),
+ prototype(name = "Asymptotically linear estimate",
+ estimate = numeric(0),
+ samplesize = numeric(0),
+ estimate.call = call("{}"),
+ asvar = NULL,
+ asbias = NULL,
+ pIC = NULL,
+ 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"))),
+ completecases = logical(0),
+ untransformed.estimate = NULL,
+ untransformed.asvar = NULL),
+ contains = "Estimate")
+
+setClass("MCALEstimate",
+ representation(pIC = "OptionalInfluenceCurveOrCall",
+ asbias = "OptionalNumeric"),
+ prototype(name = "Minimum criterion estimate (which is asy. linear)",
+ asbias = NULL,
+ pIC = NULL),
+ contains = c("ALEstimate","MCEstimate")
+)
+
+setClass("kStepEstimate",
+ representation(steps = "integer",
+ pICList = "OptionalpICList",
+ ICList = "OptionalpICList",
+ start = "StartClass",
+ startval = "matrix",
+ ustartval = "matrix",
+ ksteps = "OptionalMatrix",
+ uksteps = "OptionalMatrix",
+ robestCall = "OptionalCall"),
+ prototype(name = "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),
+ contains = "ALEstimate")
+setClass("MEstimate",
+ representation(Mroot = "numeric"),
+ prototype(name = "Asymptotically linear estimate",
+ estimate = numeric(0),
+ samplesize = numeric(0),
+ completecases = logical(0),
+ estimate.call = call("{}"),
+ Mroot = numeric(0),
+ asvar = NULL,
+ asbias = NULL,
+ pIC = NULL,
+ 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),
+ contains = "ALEstimate")
+#################################################
+## "cutoff" class
+#################################################
+setClass("cutoff", representation = representation(name = "character",
+ fct = "function",
+ cutoff.quantile = "numeric"),
+ prototype = prototype(name = "empirical",
+ fct = function(data) quantile(data),
+ cutoff.quantile = 0.95))
+
+
+#################################################
+# new risk classes
+#################################################
+setClass("interpolRisk", representation = representation(samplesize="numeric"),
+ contains = c("VIRTUAL", "RiskType"))
+setClass("OMSRRisk", contains = "interpolRisk", prototype=prototype(type=".OMSE", samplesize=100))
+setClass("RMXRRisk", contains = "interpolRisk", prototype=prototype(type=".RMXE", samplesize=100))
+setClass("MBRRisk", contains = "interpolRisk", prototype=prototype(type=".MBRE",samplesize=100))
Added: branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/AllGeneric.R
===================================================================
--- branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/AllGeneric.R (rev 0)
+++ branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/AllGeneric.R 2018-08-09 23:54:33 UTC (rev 1116)
@@ -0,0 +1,255 @@
+if(!isGeneric("radius")){
+ setGeneric("radius", function(object) standardGeneric("radius"))
+}
+if(!isGeneric("radius<-")){
+ setGeneric("radius<-", function(object,value) standardGeneric("radius<-"))
+}
+if(!isGeneric("center")){
+ setGeneric("center", function(object) standardGeneric("center"))
+}
+if(!isGeneric("center<-")){
+ setGeneric("center<-", function(object, value) standardGeneric("center<-"))
+}
+if(!isGeneric("neighbor")){
+ setGeneric("neighbor", function(object) standardGeneric("neighbor"))
+}
+if(!isGeneric("neighbor<-")){
+ setGeneric("neighbor<-", function(object, value) standardGeneric("neighbor<-"))
+}
+if(!isGeneric("Curve")){
+ setGeneric("Curve", function(object) standardGeneric("Curve"))
+}
+if(!isGeneric("Risks")){
+ setGeneric("Risks", function(object) standardGeneric("Risks"))
+}
+if(!isGeneric("Risks<-")){
+ setGeneric("Risks<-", function(object, value) standardGeneric("Risks<-"))
+}
+if(!isGeneric("addRisk<-")){
+ setGeneric("addRisk<-", function(object, value) standardGeneric("addRisk<-"))
+}
+if(!isGeneric("CallL2Fam")){
+ setGeneric("CallL2Fam", function(object) standardGeneric("CallL2Fam"))
+}
+if(!isGeneric("CallL2Fam<-")){
+ setGeneric("CallL2Fam<-", function(object, value) standardGeneric("CallL2Fam<-"))
+}
+if(!isGeneric("generateIC")){
+ setGeneric("generateIC", function(neighbor, L2Fam, ...) standardGeneric("generateIC"))
+}
+if(!isGeneric("checkIC")){
+ setGeneric("checkIC", function(IC, L2Fam, ...) standardGeneric("checkIC"))
+}
+if(!isGeneric("evalIC")){
+ setGeneric("evalIC", function(IC, x) standardGeneric("evalIC"))
+}
+if(!isGeneric("evalIC.v")){
+ setGeneric("evalIC.v", function(IC, x) standardGeneric("evalIC.v"))
+}
+if(!isGeneric("makeIC")){
+ setGeneric("makeIC", function(IC, L2Fam, ...) standardGeneric("makeIC"))
+}
+if(!isGeneric("clip")){
+ setGeneric("clip", function(x1, ...) standardGeneric("clip"))
+}
+if(!isGeneric("clip<-")){
+ setGeneric("clip<-", function(object, value) standardGeneric("clip<-"))
+}
+if(!isGeneric("cent")){
+ setGeneric("cent", function(object) standardGeneric("cent"))
+}
+if(!isGeneric("cent<-")){
+ setGeneric("cent<-", function(object, value) standardGeneric("cent<-"))
+}
+if(!isGeneric("stand")){
+ setGeneric("stand", function(object) standardGeneric("stand"))
+}
+if(!isGeneric("stand<-")){
+ setGeneric("stand<-", function(object, value) standardGeneric("stand<-"))
+}
+if(!isGeneric("lowerCase")){
+ setGeneric("lowerCase", function(object) standardGeneric("lowerCase"))
+}
+if(!isGeneric("lowerCase<-")){
+ setGeneric("lowerCase<-", function(object, value) standardGeneric("lowerCase<-"))
+}
+if(!isGeneric("neighborRadius")){
+ setGeneric("neighborRadius", function(object) standardGeneric("neighborRadius"))
+}
+if(!isGeneric("neighborRadius<-")){
+ setGeneric("neighborRadius<-", function(object, value) standardGeneric("neighborRadius<-"))
+}
+if(!isGeneric("clipLo")){
+ setGeneric("clipLo", function(object) standardGeneric("clipLo"))
+}
+if(!isGeneric("clipLo<-")){
+ setGeneric("clipLo<-", function(object, value) standardGeneric("clipLo<-"))
+}
+if(!isGeneric("clipUp")){
+ setGeneric("clipUp", function(object) standardGeneric("clipUp"))
+}
+if(!isGeneric("clipUp<-")){
+ setGeneric("clipUp<-", function(object, value) standardGeneric("clipUp<-"))
+}
+#if(!isGeneric("oneStepEstimator")){
+# setGeneric("oneStepEstimator",
+# function(x, IC, start, ...) standardGeneric("oneStepEstimator"))
+#}
+#if(!isGeneric("kStepEstimator")){
+# setGeneric("kStepEstimator",
+# function(x, IC, start, ...) standardGeneric("kStepEstimator"))
+#}
+if(!isGeneric("locMEstimator")){
+ setGeneric("locMEstimator", function(x, IC, ...) standardGeneric("locMEstimator"))
+}
+if(!isGeneric("infoPlot")){
+ setGeneric("infoPlot", function(object,...) standardGeneric("infoPlot"))
+}
+if(!isGeneric("optIC")){
+ setGeneric("optIC", function(model, risk, ...) standardGeneric("optIC"))
+}
+
+
+if(!isGeneric("weight")){
+ setGeneric("weight",
+ function(object, ...) standardGeneric("weight"))
+}
+if(!isGeneric("weight<-")){
+ setGeneric("weight<-",
+ function(object, value) standardGeneric("weight<-"))
+}
+if(!isGeneric("clip<-")){
+ setGeneric("clip<-",
+ function(object, value, ...) standardGeneric("clip<-"))
+}
+if(!isGeneric("stand")){
+ setGeneric("stand",
+ function(object, ...) standardGeneric("stand"))
+}
+if(!isGeneric("stand<-")){
+ setGeneric("stand<-",
+ function(object, value, ...) standardGeneric("stand<-"))
+}
+if(!isGeneric("cent")){
+ setGeneric("cent",
+ function(object, ...) standardGeneric("cent"))
+}
+if(!isGeneric("cent<-")){
+ setGeneric("cent<-",
+ function(object, value, ...) standardGeneric("cent<-"))
+}
+
+if(!isGeneric("getweight")){
+ setGeneric("getweight",
+ function(Weight, neighbor, biastype, ...) standardGeneric("getweight"))
+}
+
+if(!isGeneric("minbiasweight")){
+ setGeneric("minbiasweight",
+ function(Weight, neighbor, biastype, ...) standardGeneric("minbiasweight"))
+}
+if(!isGeneric("generateIC.fct")){
+ setGeneric("generateIC.fct", function(neighbor, L2Fam, ...) standardGeneric("generateIC.fct"))
+}
+if(!isGeneric("getRiskIC")){
+ setGeneric("getRiskIC",
+ function(IC, risk, neighbor, L2Fam, ...) standardGeneric("getRiskIC"))
+}
+if(!isGeneric("getBiasIC")){
+ setGeneric("getBiasIC",
+ function(IC, neighbor, ...) standardGeneric("getBiasIC"))
+}
+if(!isGeneric(".evalBiasIC")){
+ setGeneric(".evalBiasIC",
+ function(IC, neighbor, biastype, ...) standardGeneric(".evalBiasIC"))
+}
+if(!isGeneric("comparePlot")){
+ setGeneric("comparePlot", function(obj1,obj2,...) standardGeneric("comparePlot"))
+}
+if(!isGeneric("pIC")){
+ setGeneric("pIC", function(object) standardGeneric("pIC"))
+}
+if(!isGeneric("asbias")){
+ setGeneric("asbias", function(object) standardGeneric("asbias"))
+}
+if(!isGeneric("steps")){
+ setGeneric("steps", function(object) standardGeneric("steps"))
+}
+if(!isGeneric("ksteps")){
+ setGeneric("ksteps", function(object,...) standardGeneric("ksteps"))
+}
+if(!isGeneric("uksteps")){
+ setGeneric("uksteps", function(object,...) standardGeneric("uksteps"))
+}
+if(!isGeneric("start")){
+ setGeneric("start", function(x, ...) standardGeneric("start"))
+}
+if(!isGeneric("startval")){
+ setGeneric("startval", function(object) standardGeneric("startval"))
+}
+if(!isGeneric("ustartval")){
+ setGeneric("ustartval", function(object) standardGeneric("ustartval"))
+}
+if(!isGeneric("ICList")){
+ setGeneric("ICList", function(object) standardGeneric("ICList"))
+}
+if(!isGeneric("pICList")){
+ setGeneric("pICList", function(object) standardGeneric("pICList"))
+}
+if(!isGeneric("robestCall")){
+ setGeneric("robestCall", function(object) standardGeneric("robestCall"))
+}
+if(!isGeneric("Mroot")){
+ setGeneric("Mroot", function(object) standardGeneric("Mroot"))
+}
+if(!isGeneric("modifyIC")){
+ setGeneric("modifyIC", function(object) standardGeneric("modifyIC"))
+}
+if(!isGeneric("cutoff.quantile")){
+ setGeneric("cutoff.quantile", function(object) standardGeneric("cutoff.quantile"))
+}
+if(!isGeneric("cutoff.quantile<-")){
+ setGeneric("cutoff.quantile<-", function(object,value)
+ standardGeneric("cutoff.quantile<-"))
+}
+if(!isGeneric("ddPlot")){
+ setGeneric("ddPlot", function(data, dist.x, dist.y, cutoff.x, cutoff.y,...)
+ standardGeneric("ddPlot"))
+}
+if(!isGeneric("kStepEstimator.start")){
+ setGeneric("kStepEstimator.start",
+ function(start,...) standardGeneric("kStepEstimator.start"))
+}
+if(!isGeneric("radius")){
+ setGeneric("radius", function(object) standardGeneric("radius"))
+}
+
+if(!isGeneric("samplesize<-")){
+ setGeneric("samplesize<-",
+ function(object, value) standardGeneric("samplesize<-"))
+}
+if(!isGeneric("getRiskFctBV")){
+ setGeneric("getRiskFctBV", function(risk, biastype) standardGeneric("getRiskFctBV"))
+}
+
+if(!isGeneric("moveL2Fam2RefParam")){
+ setGeneric("moveL2Fam2RefParam", function(L2Fam, ...)
+ standardGeneric("moveL2Fam2RefParam"))
+}
+
+if(!isGeneric("moveICBackFromRefParam")){
+ setGeneric("moveICBackFromRefParam", function(IC, L2Fam, ...)
+ standardGeneric("moveICBackFromRefParam"))
+}
+
+if(!isGeneric("rescaleFunction")){
+ setGeneric("rescaleFunction", function(L2Fam, ...)
+ standardGeneric("rescaleFunction"))
+}
+if(!isGeneric("getFiRisk")){
+ setGeneric("getFiRisk",
+ function(risk, Distr, neighbor, ...) standardGeneric("getFiRisk"))
+}
+if(!isGeneric("getPIC")){
+ setGeneric("getPIC", function(estimator) standardGeneric("getPIC"))
+}
Added: branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/ContIC.R
===================================================================
--- branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/ContIC.R (rev 0)
+++ branches/robast-1.2/pkg/20080808RobAStBaseDeadEnd/ContIC.R 2018-08-09 23:54:33 UTC (rev 1116)
@@ -0,0 +1,176 @@
+## Generating function
+ContIC <- function(name, CallL2Fam = call("L2ParamFamily"),
+ Curve = EuclRandVarList(RealRandVariable(Map = c(function(x){x}),
+ Domain = Reals())),
+ Risks, Infos, clip = Inf, cent = 0, stand = as.matrix(1),
+ lowerCase = NULL, neighborRadius = 0, w = new("HampelWeight"),
+ normtype = NormType(), biastype = symmetricBias(),
+ modifyIC = NULL, .fastFct = NULL){
+ if(missing(name))
+ name <- "IC of contamination type"
+ if(missing(Risks))
+ Risks <- list()
+ if(missing(Infos))
+ Infos <- matrix(c(character(0),character(0)), ncol=2,
+ dimnames=list(character(0), c("method", "message")))
+
+ if(any(neighborRadius < 0)) # radius vector?!
+ stop("'neighborRadius' has to be in [0, Inf]")
+ if(length(cent) != nrow(stand))
+ stop("length of centering constant != nrow of standardizing matrix")
+ if((length(clip) != 1) && (length(clip) != length(Curve)))
+ stop("length of clipping bound != 1 and != length of 'Curve'")
+ if(!is.null(lowerCase))
+ if(length(lowerCase) != nrow(stand))
+ stop("length of 'lowerCase' != nrow of standardizing matrix")
+ L2Fam <- eval(CallL2Fam)
+ if(!identical(dim(trafo(L2Fam at param)), dim(stand)))
+ stop(paste("dimension of 'trafo' of 'param' != dimension of 'stand'"))
+
+ contIC <- new("ContIC")
+ contIC at name <- name
+ contIC at Curve <- Curve
+ contIC at Risks <- Risks
+ contIC at Infos <- Infos
+ contIC at CallL2Fam <- CallL2Fam
+ contIC at clip <- clip
+ contIC at cent <- cent
+ contIC at stand <- stand
+ contIC at lowerCase <- lowerCase
+ contIC at neighborRadius <- neighborRadius
+ contIC at weight <- w
+ contIC at biastype <- biastype
+ contIC at normtype <- normtype
+ contIC at modifyIC <- modifyIC
+ contIC at .fastFct <- .fastFct
+
+ return(contIC)
+# return(new("ContIC", name = name, Curve = Curve, Risks = Risks, Infos = Infos,
+# CallL2Fam = CallL2Fam, clip = clip, cent = cent, stand = stand,
+# lowerCase = lowerCase, neighborRadius = neighborRadius))
+}
+
+
+setMethod("generateIC", signature(neighbor = "ContNeighborhood",
+ L2Fam = "L2ParamFamily"),
+ function(neighbor, L2Fam, res){
+ A <- res$A
+ a <- res$a
+ b <- res$b
+ d <- res$d
+ normtype <- res$normtype
+ biastype <- res$biastype
+ w <- res$w
+ L2call <- L2Fam at fam.call
+ L2call$trafo <- trafo(L2Fam)
+ return(ContIC(
+ name = "IC of contamination type",
+ CallL2Fam = L2call,
+ Curve = generateIC.fct(neighbor, L2Fam, res),
+ .fastFct = generateIC.fast.fct(neighbor, L2Fam, res),
+ clip = b,
+ cent = a,
+ stand = A,
+ lowerCase = d,
+ w = w,
+ neighborRadius = neighbor at radius,
+ modifyIC = res$modifyIC,
+ normtype = normtype,
+ biastype = biastype,
+ Risks = res$risk,
+ Infos = matrix(res$info, ncol = 2,
+ dimnames = list(character(0), c("method", "message")))))
+ })
+
+## Access methods
+setMethod("clip", "ContIC", function(x1) x1 at clip)
+setMethod("cent", "ContIC", function(object) object at cent)
+setMethod("neighbor", "ContIC", function(object) ContNeighborhood(radius = object at neighborRadius) )
+
+## replace methods
+setReplaceMethod("clip", "ContIC",
+ function(object, value){
+ stopifnot(is.numeric(value))
+ L2Fam <- eval(object at CallL2Fam)
+ w <- object at weight
+ clip(w) <- value
+ weight(w) <- getweight(w, neighbor = ContNeighborhood(radius = object at neighborRadius),
+ biastype = object at biastype,
+ normW = object at normtype)
+ res <- list(A = object at stand, a = object at cent, b = value, d = object at lowerCase,
+ risk = object at Risks, info = object at Infos, w = w,
+ normtype = object at normtype, biastype = object at biastype,
+ modifyIC = object at modifyIC)
+ object <- generateIC(neighbor = ContNeighborhood(radius = object at neighborRadius),
+ L2Fam = L2Fam, res = res)
+ addInfo(object) <- c("clip<-", "The clipping bound has been changed")
+ addInfo(object) <- c("clip<-", "The entries in 'Risks' and 'Infos' may be wrong")
+ object
+ })
+setReplaceMethod("cent", "ContIC",
+ function(object, value){
+ stopifnot(is.numeric(value))
+ L2Fam <- eval(object at CallL2Fam)
+ w <- object at weight
+ cent(w) <- as.vector(solve(object at stand) %*% value)
+ weight(w) <- getweight(w, neighbor = ContNeighborhood(radius = object at neighborRadius),
+ biastype = object at biastype,
+ normW = object at normtype)
+ res <- list(A = object at stand, a = value, b = object at clip, d = object at lowerCase,
+ risk = object at Risks, info = object at Infos, w = w,
+ normtype = object at normtype, biastype = object at biastype,
+ modifyIC = object at modifyIC)
+ object <- generateIC(neighbor = ContNeighborhood(radius = object at neighborRadius),
+ L2Fam = L2Fam, res = res)
+ addInfo(object) <- c("cent<-", "The centering constant has been changed")
+ addInfo(object) <- c("cent<-", "The entries in 'Risks' and 'Infos' may be wrong")
+ object
+ })
+setReplaceMethod("stand", "ContIC",
+ function(object, value){
+ stopifnot(is.matrix(value))
+ L2Fam <- eval(object at CallL2Fam)
+ w <- object at weight
+ stand(w) <- value
+ weight(w) <- getweight(w, neighbor = ContNeighborhood(radius = object at neighborRadius),
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/robast -r 1116
More information about the Robast-commits
mailing list