R/ContIC.R

Defines functions ContIC

Documented in ContIC

## 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){
    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@param)), dim(stand)))
        stop(paste("dimension of 'trafo' of 'param' != dimension of 'stand'"))
 
    contIC <- new("ContIC")
    contIC@name <- name
    contIC@Curve <- Curve
    contIC@Risks <- Risks
    contIC@Infos <- Infos
    contIC@CallL2Fam <- CallL2Fam
    contIC@clip <- clip
    contIC@cent <- cent
    contIC@stand <- stand
    contIC@lowerCase <- lowerCase
    contIC@neighborRadius <- neighborRadius
    contIC@weight <- w
    contIC@biastype <- biastype
    contIC@normtype <- normtype
    contIC@modifyIC <- modifyIC

    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@fam.call
        L2call$trafo <- trafo(L2Fam)
        return(ContIC(
                name = "IC of contamination type", 
                CallL2Fam = L2call,
                Curve = generateIC.fct(neighbor, L2Fam, res),
                clip = b,
                cent = a,
                stand = A,
                lowerCase = d,
                w = w,
                neighborRadius = neighbor@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@clip)
setMethod("cent", "ContIC", function(object) object@cent)
setMethod("neighbor", "ContIC", function(object) ContNeighborhood(radius = object@neighborRadius) )

## replace methods
setReplaceMethod("clip", "ContIC", 
    function(object, value){ 
        stopifnot(is.numeric(value))
        L2Fam <- eval(object@CallL2Fam)
        w <- object@weight
        clip(w) <- value
        weight(w) <- getweight(w, neighbor = ContNeighborhood(radius = object@neighborRadius), 
                               biastype = object@biastype, 
                               normW = object@normtype)
        res <- list(A = object@stand, a = object@cent, b = value, d = object@lowerCase,
                    risk = object@Risks, info = object@Infos, w = w,
                    normtype = object@normtype, biastype = object@biastype,
                    modifyIC = object@modifyIC)
        object <- generateIC(neighbor = ContNeighborhood(radius = object@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@CallL2Fam)
        w <- object@weight
        cent(w) <- as.vector(distr::solve(object@stand) %*% value)
        weight(w) <- getweight(w, neighbor = ContNeighborhood(radius = object@neighborRadius), 
                               biastype = object@biastype, 
                               normW = object@normtype)
        res <- list(A = object@stand, a = value, b = object@clip, d = object@lowerCase,
                    risk = object@Risks, info = object@Infos, w = w,
                    normtype = object@normtype, biastype = object@biastype,
                    modifyIC = object@modifyIC)
        object <- generateIC(neighbor = ContNeighborhood(radius = object@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@CallL2Fam)
        w <- object@weight
        stand(w) <- value
        weight(w) <- getweight(w, neighbor = ContNeighborhood(radius = object@neighborRadius), 
                               biastype = object@biastype, 
                               normW = object@normtype)
        res <- list(A = value, a = object@cent, b = object@clip, d = object@lowerCase,
                    risk = object@Risks, info = object@Infos, w = w,
                    normtype = object@normtype, biastype = object@biastype,
                    modifyIC = object@modifyIC)
        object <- generateIC(neighbor = ContNeighborhood(radius = object@neighborRadius), 
                             L2Fam = L2Fam, res = res)
        addInfo(object) <- c("stand<-", "The standardizing matrix has been changed")
        addInfo(object) <- c("stand<-", "The entries in 'Risks' and 'Infos' may be wrong")
        object
    })
setReplaceMethod("lowerCase", "ContIC", 
    function(object, value){ 
        stopifnot(is.null(value)||is.numeric(value))
        L2Fam <- eval(object@CallL2Fam)
        res <- list(A = object@stand, a = object@cent, b = object@clip, d = value,
                    risk = object@Risks, info = object@Infos, w = object@weight,
                    normtype = object@normtype, biastype = object@biastype,
                    modifyIC = object@modifyIC)
        object <- generateIC(neighbor = ContNeighborhood(radius = object@neighborRadius), 
                             L2Fam = L2Fam, res = res)
        addInfo(object) <- c("lowerCase<-", "The slot 'lowerCase' has been changed")
        addInfo(object) <- c("lowerCase<-", "The entries in 'Risks' and 'Infos' may be wrong")
        object
    })
setReplaceMethod("CallL2Fam", "ContIC",
    function(object, value){ 
        L2Fam <- eval(value)
        res <- list(A = object@stand, a = object@cent, b = object@clip, d = object@lowerCase,
                    risk = object@Risks, info = object@Infos, w = object@weight,
                    normtype = object@normtype, biastype = object@biastype,
                    modifyIC = object@modifyIC)
        object <- generateIC(neighbor = ContNeighborhood(radius = object@neighborRadius), 
                             L2Fam = L2Fam, res = res)
        addInfo(object) <- c("CallL2Fam<-", "The slot 'CallL2Fam' has been changed")
        addInfo(object) <- c("CallL2Fam<-", "The entries in 'Risks' and 'Infos' may be wrong")
        object
    })
## comment 20180809: reverted changes in rev 1110

Try the RobAStBase package in your browser

Any scripts or data that you put into this service are public.

RobAStBase documentation built on May 2, 2019, 4:14 p.m.