Nothing
###############################################################################
## internal functions/methods to fill slot modifyIC
###############################################################################
setMethod("getModifyIC", signature(L2FamIC = "L2ParamFamily",
neighbor = "Neighborhood", risk = "asRisk"),
function(L2FamIC, neighbor, risk, ...){
mc <- match.call(call = sys.call(sys.parent(1)), expand.dots=FALSE)
mcl <- as.list(mc)[-1]
dots <- mcl[["..."]]
dots$verbose <- NULL
dots$warn <- FALSE
modIC <- function(L2Fam, IC, withMakeIC = FALSE, ...){}
body(modIC) <- substitute({ verbose <- getRobAStBaseOption("all.verbose")
infMod <- InfRobModel(L2Fam, nghb)
IC.0 <- do.call(optIC, args = c(list(infMod, risk=R),
dots0))
if(withMakeIC) IC.0 <- makeIC(IC.0, L2Fam, ...)
return(IC.0)
},
list(nghb = neighbor, R = risk,
dots0 = eval(dots, envir=parent.frame(2))))
return(modIC)
})
setMethod("getModifyIC", signature(L2FamIC = "L2LocationFamily",
neighbor = "UncondNeighborhood", risk = "asGRisk"),
function(L2FamIC, neighbor, risk, ...){
modIC <- function(L2Fam, IC, withMakeIC = FALSE, ...){
D <- distribution(eval(CallL2Fam(IC)))
if(is(L2Fam, "L2LocationFamily") && is(distribution(L2Fam), class(D))){
CallL2Fam(IC) <- fam.call(L2Fam)
return(IC)
}else{
makeIC(IC, L2Fam, ...)
}
}
return(modIC)
})
setMethod("getModifyIC", signature(L2FamIC = "L2LocationFamily",
neighbor = "UncondNeighborhood", risk = "fiUnOvShoot"),
getMethod("getModifyIC",signature(L2FamIC = "L2LocationFamily",
neighbor = "UncondNeighborhood", risk = "asGRisk"))
)
setMethod("scaleUpdateIC", signature(neighbor="UncondNeighborhood"),
function(neighbor, sdneu, sdalt, IC){
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 = neighbor,
biastype = biastype(IC),
normW = normtype(IC))
A <- sdneu^2*stand(IC)/sdalt^2
risk0 <- Risks(IC)
risk <- NULL
risk$asMSE <- if(is.numeric(risk0$asMSE))
risk0$asMSE * sdneu^2 / sdalt^2 else NULL
if(is.list(risk0$asMSE)){
amse <- risk0$asMSE; risk$asCov <- amse
if(is.numeric(amse$value))
risk$asMSE$value <- amse$value * sdneu^2 / sdalt^2
}
risk$asCov <- if(is.numeric(risk0$asCov))
risk0$asCov * sdneu^2 / sdalt^2 else NULL
if(is.list(risk0$asCov)){
aCov <- risk0$asCov; risk$asCov <- aCov
if(is.numeric(aCov$value))
risk$asCov$value <- aCov$value * sdneu^2 / sdalt^2
}
risk$asBias <- if(is.numeric(risk0$asBias))
risk0$asBias * sdneu / sdalt else NULL
if(is.list(risk0$asBias)){
abias <- risk0$asBias; risk$asBias <- abias
if(is.numeric(abias$value))
risk$asBias$value <- abias$value * sdneu / sdalt
}
return(list(A = A, d = NULL,
info = Infos(IC), w = w, risk = risk,
normtype = normtype(IC), biastype = biastype(IC),
modifyIC = modifyIC(IC)))
})
setMethod("scaleUpdateIC", signature(neighbor="ContNeighborhood"),
function(neighbor, sdneu, sdalt, IC){
r <- neighborRadius(IC)
fct <- getMethod("scaleUpdateIC",signature(neighbor="UncondNeighborhood"))
res <- fct(neighbor, sdneu, sdalt, IC); w <- res$w; A <- res$A
b <- sdneu*clip(IC)/sdalt
a <- sdneu*cent(IC)/sdalt
cent(w) <- sdalt*cent(w)/sdneu
weight(w) <- getweight(w, neighbor, biastype = biastype(IC),
normW = normtype(IC))
return(c(res,list(a = a, b = b, w = w)))
})
setMethod("scaleUpdateIC", signature(neighbor="TotalVarNeighborhood"),
function(neighbor, sdneu, sdalt, IC){
r <- neighborRadius(IC)
fct <- getMethod("scaleUpdateIC",signature(neighbor="UncondNeighborhood"))
res <- fct(neighbor, sdneu, sdalt, IC); w <- res$w; A <- res$A
blo <- sdneu*clipLo(IC)/sdalt
b <- sdneu*clipUp(IC)/sdalt - blo
weight(w) <- getweight(w, neighbor, biastype = biastype(IC),
normW = normtype(IC))
return(c(res,list(a = blo, b = b, w = w)))
})
setMethod("getModifyIC", signature(L2FamIC = "L2ScaleFamily",
neighbor = "UncondNeighborhood", risk = "asGRisk"),
function(L2FamIC, neighbor, risk, ..., modifyICwarn = NULL){
if(missing(modifyICwarn)|| is.null(modifyICwarn))
modifyICwarn <- getRobAStBaseOption("modifyICwarn")
modIC <- function(L2Fam, IC, withMakeIC = FALSE, ...){
ICL2Fam <- eval(CallL2Fam(IC))
if(is(L2Fam, "L2ScaleFamily") && is(distribution(L2Fam), class(distribution(ICL2Fam)))){
res <- scaleUpdateIC(sdneu = main(L2Fam),
sdalt = main(ICL2Fam),
IC = IC, neighbor = neighbor)
IC <- generateIC(neighbor = neighbor, L2Fam = L2Fam, res = res)
if(!any(grepl("Some entries in 'Infos' may be wrong", Infos(IC)[,2])) && modifyICwarn){
addInfo(IC) <- c("modifyIC", "The IC has been modified")
addInfo(IC) <- c("modifyIC", "Some entries in 'Infos' may be wrong")
}
return(IC)
}else{
makeIC(IC, L2Fam, ...)
}
}
return(modIC)
})
setMethod("getModifyIC", signature(L2FamIC = "L2LocationScaleFamily",
neighbor = "UncondNeighborhood", risk = "asGRisk"),
function(L2FamIC, neighbor, risk, ..., modifyICwarn = NULL){
if(missing(modifyICwarn)|| is.null(modifyICwarn))
modifyICwarn <- getRobAStBaseOption("modifyICwarn")
modIC <- function(L2Fam, IC, withMakeIC = FALSE, ...){
ICL2Fam <- eval(CallL2Fam(IC))
if(is(L2Fam, "L2LocationScaleFamily") && is(distribution(L2Fam),
class(distribution(ICL2Fam)))){
r <- neighborRadius(IC)
scl.nm <- L2Fam@locscalename["scale"]
if(scl.nm %in% names(main(L2Fam))){
sdneu <- main(L2Fam)[scl.nm]
sdalt <- main(ICL2Fam)[scl.nm]
}else{
sdneu <- nuisance(L2Fam)
sdalt <- nuisance(ICL2Fam)
}
res <- scaleUpdateIC(sdneu = sdneu, sdalt = sdalt,
IC = IC, neighbor = neighbor)
IC <- generateIC(neighbor = neighbor, L2Fam = L2Fam, res = res)
if(!any(grepl("Some entries in 'Infos' may be wrong", Infos(IC)[,2])) && modifyICwarn){
addInfo(IC) <- c("modifyIC", "The IC has been modified")
addInfo(IC) <- c("modifyIC", "Some entries in 'Infos' may be wrong")
}
return(IC)
}else{
makeIC(IC, L2Fam, ...)
}
}
return(modIC)
})
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.