[Robast-commits] r1053 - branches/robast-1.2/pkg/ROptRegTS/R pkg/ROptRegTS/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Jul 24 14:36:46 CEST 2018
Author: ruckdeschel
Date: 2018-07-24 14:36:46 +0200 (Tue, 24 Jul 2018)
New Revision: 1053
Modified:
branches/robast-1.2/pkg/ROptRegTS/R/ContIC.R
branches/robast-1.2/pkg/ROptRegTS/R/getIneffDiff.R
branches/robast-1.2/pkg/ROptRegTS/R/leastFavorableRadius.R
branches/robast-1.2/pkg/ROptRegTS/R/radiusMinimaxIC.R
pkg/ROptRegTS/R/ContIC.R
pkg/ROptRegTS/R/getIneffDiff.R
pkg/ROptRegTS/R/leastFavorableRadius.R
pkg/ROptRegTS/R/radiusMinimaxIC.R
Log:
[ROptRegTS] fixed yet yet another problem with merge... not all new files were transported... (fixed in trunk and in branch 1.2)
Modified: branches/robast-1.2/pkg/ROptRegTS/R/ContIC.R
===================================================================
--- branches/robast-1.2/pkg/ROptRegTS/R/ContIC.R 2018-07-24 12:19:48 UTC (rev 1052)
+++ branches/robast-1.2/pkg/ROptRegTS/R/ContIC.R 2018-07-24 12:36:46 UTC (rev 1053)
@@ -1,51 +1,7 @@
-## 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){
- 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(L2Fam at param@trafo), 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
-
- 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))
-}
-
## generate IC
## for internal use only!
setMethod("generateIC", signature(neighbor = "ContNeighborhood",
- L2Fam = "L2ParamFamily"),
+ L2Fam = "L2RegTypeFamily"),
function(neighbor, L2Fam, res){
A <- res$A
a <- res$a
@@ -56,13 +12,13 @@
Y <- as(A %*% L2Fam at L2deriv - a, "EuclRandVariable")
if(nrvalues == 1){
if(!is.null(d)){
- ICfct[[1]] <- function(x){}#
- #ind <- (Y(x) != 0)
- # b*(ind*Y(x)/(ind*absY(x) + (1-ind)) + zi*(1-ind)*d)
- #}
+ ICfct[[1]] <- function(x){}
+ # ind <- (Y(x) != 0)
+ # b*(ind*Y(x)/(ind*absY(x) + (1-ind)*1) + zi*(1-ind)*d)
+ # }
body(ICfct[[1]]) <- substitute(
{ ind <- (Y(x) != 0)
- b*(ind*Y(x)/(ind*absY(x) + (1-ind)) + zi*(1-ind)*d) },
+ b*(ind*Y(x)/(ind*absY(x) + (1-ind)*1) + zi*(1-ind)*d) },
list(Y = Y at Map[[1]], absY = abs(Y)@Map[[1]], b = b, d = d,
zi = sign(L2Fam at param@trafo)))
}else{
@@ -70,7 +26,8 @@
body(ICfct[[1]]) <- substitute({ Y(x)*pmin(1, b/absY(x)) },
list(Y = Y at Map[[1]], absY = abs(Y)@Map[[1]], b = b))
}
- }else{
+ }
+ else{
absY <- sqrt(Y %*% Y)
if(!is.null(d))
for(i in 1:nrvalues){
@@ -86,17 +43,21 @@
}
}
return(ContIC(
- name = "IC of contamination type",
- CallL2Fam = call("L2ParamFamily",
+ name = "IC of contamination type",
+ CallL2Fam = call("L2RegTypeFamily",
name = L2Fam at name,
- distribution = L2Fam at distribution,
- distrSymm = L2Fam at distrSymm,
+ distribution = L2Fam at distribution,
param = L2Fam at param,
props = L2Fam at props,
+ ErrorDistr = L2Fam at ErrorDistr,
+ ErrorSymm = L2Fam at ErrorSymm,
+ RegDistr = L2Fam at RegDistr,
+ RegSymm = L2Fam at RegSymm,
+ Regressor = L2Fam at Regressor,
L2deriv = L2Fam at L2deriv,
- L2derivSymm = L2Fam at L2derivSymm,
- L2derivDistr = L2Fam at L2derivDistr,
- L2derivDistrSymm = L2Fam at L2derivDistrSymm,
+ ErrorL2deriv = L2Fam at ErrorL2deriv,
+ ErrorL2derivDistr = L2Fam at ErrorL2derivDistr,
+ ErrorL2derivSymm = L2Fam at ErrorL2derivSymm,
FisherInfo = L2Fam at FisherInfo),
Curve = EuclRandVarList(EuclRandVariable(Map = ICfct, Domain = Y at Domain,
Range = Y at Range)),
@@ -109,80 +70,3 @@
Infos = matrix(res$info, ncol = 2,
dimnames = list(character(0), c("method", "message")))))
})
-
-## Access methods
-setMethod("clip", "ContIC", function(object) object at clip)
-setMethod("cent", "ContIC", function(object) object at cent)
-setMethod("stand", "ContIC", function(object) object at stand)
-setMethod("lowerCase", "ContIC", function(object) object at lowerCase)
-setMethod("neighborRadius", "ContIC", function(object) object at neighborRadius)
-
-## replace methods
-setReplaceMethod("clip", "ContIC",
- function(object, value){
- stopifnot(is.numeric(value))
- L2Fam <- eval(object at CallL2Fam)
- res <- list(A = object at stand, a = object at cent, b = value, d = object at lowerCase,
- risk = object at Risks, info = object at Infos)
- 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)
- res <- list(A = object at stand, a = value, b = object at clip, d = object at lowerCase,
- risk = object at Risks, info = object at Infos)
- 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)
- res <- list(A = value, a = object at cent, b = object at clip, d = object at lowerCase,
- risk = object at Risks, info = object at Infos)
- object <- generateIC(neighbor = ContNeighborhood(radius = object at 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 at CallL2Fam)
- res <- list(A = object at stand, a = object at cent, b = object at clip, d = value,
- risk = object at Risks, info = object at Infos)
- object <- generateIC(neighbor = ContNeighborhood(radius = object at 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("neighborRadius", "ContIC",
- function(object, value){
- object at neighborRadius <- value
- if(any(value < 0)) # radius vector?!
- stop("'value' has to be in [0, Inf]")
- addInfo(object) <- c("neighborRadius<-", "The slot 'neighborRadius' has been changed")
- addInfo(object) <- c("neighborRadius<-", "The entries in 'Risks' and 'Infos' may be wrong")
- object
- })
-setReplaceMethod("CallL2Fam", "ContIC",
- function(object, value){
- L2Fam <- eval(value)
- res <- list(A = object at stand, a = object at cent, b = object at clip, d = object at lowerCase,
- risk = object at Risks, info = object at Infos)
- object <- generateIC(neighbor = ContNeighborhood(radius = object at 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
- })
Modified: branches/robast-1.2/pkg/ROptRegTS/R/getIneffDiff.R
===================================================================
--- branches/robast-1.2/pkg/ROptRegTS/R/getIneffDiff.R 2018-07-24 12:19:48 UTC (rev 1052)
+++ branches/robast-1.2/pkg/ROptRegTS/R/getIneffDiff.R 2018-07-24 12:36:46 UTC (rev 1053)
@@ -22,13 +22,12 @@
ineffUp <- res$b^2/upRisk
else
ineffUp <- (sum(diag(res$A %*% t(trafo))) - res$b^2*(radius^2-upRad^2))/upRisk
-## changed: shakey... assign("ineff", ineffUp, envir = sys.frame(which = -4))
-# return(ineffUp - ineffLo)
- return(c(ineff=ineffUp,ineffDiff=ineffUp - ineffLo))
- }else{
+ assign("ineff", ineffUp, envir = sys.frame(which = -4))
if(is(L2Fam at RegDistr, "MultivariateDistribution"))
cat("current radius:\t", radius, "\tMSE-inefficiency difference:\t", ineffUp - ineffLo, "\n")
+ return(ineffUp - ineffLo)
+ }else{
if(is(L2Fam at ErrorDistr, "UnivariateDistribution")){
if((length(L2Fam at ErrorL2deriv) == 1)
& is(L2Fam at ErrorL2deriv[[1]], "RealRandVariable")){
@@ -65,11 +64,11 @@
ineffUp <- res$b^2/upRisk
else
ineffUp <- (sum(diag(res$A%*%t(trafo))) - res$b^2*(radius^2-upRad^2))/upRisk
- ## changed: shakey assign("ineff", ineffUp, envir = sys.frame(which = -4))
+# assign("ineff", ineffUp, envir = sys.frame(which = -4))
+
cat("current radius:\t", radius, "\tMSE-inefficiency difference:\t", ineffUp - ineffLo, "\n")
-
- ## return(ineffUp - ineffLo)
- return(c(ineff=ineffUp,ineffDiff=ineffUp - ineffLo))
+ return(c(ineff=ineffUp, ineffDiff=ineffUp-ineffLo))
+# return(ineffUp - ineffLo)
}else{
stop("not yet implemented")
}
@@ -97,10 +96,11 @@
ineffUp <- res$b^2/upRisk
else
ineffUp <- (res$A*sum(diag(t(trafo) %*% K.inv)) - res$b^2*(radius^2-upRad^2))/upRisk
- assign("ineff", ineffUp, envir = sys.frame(which = -4))
+# assign("ineff", ineffUp, envir = sys.frame(which = -4))
# cat("current radius:\t", radius, "\tMSE-inefficiency difference:\t", ineffUp - ineffLo, "\n")
- return(ineffUp - ineffLo)
+ return(c(ineff=ineffUp, ineffDiff=ineffUp-ineffLo))
+# return(ineffUp - ineffLo)
}else{
stop("not yet implemented")
}
Modified: branches/robast-1.2/pkg/ROptRegTS/R/leastFavorableRadius.R
===================================================================
--- branches/robast-1.2/pkg/ROptRegTS/R/leastFavorableRadius.R 2018-07-24 12:19:48 UTC (rev 1052)
+++ branches/robast-1.2/pkg/ROptRegTS/R/leastFavorableRadius.R 2018-07-24 12:36:46 UTC (rev 1053)
@@ -63,12 +63,11 @@
clip = resUp$b, cent = resUp$a, stand = resUp$A,
trafo = L2Fam at param@trafo)[[1]]
}
-
ineff <- NULL
getIneffDiff.1 <- function(x){
res <- getIneffDiff(x, L2Fam = L2Fam, neighbor = neighbor,
upper.b = upper.b, risk = risk, loRad = loRad, upRad = upRad,
- loRisk = loRisk, upRisk = upRisk, eps = .Machine$double.eps^0.25,
+ loRisk = loRisk, upRisk = upRisk, eps = eps,
MaxIter = MaxIter, warn = warn)
ineff <<- res["ineff"]
return(res["ineffDiff"])
@@ -111,7 +110,7 @@
ErrorL2derivDistrSymm <- new("DistrSymmList", L2)
}
}
- leastFavFct.p <- function(r, L2Fam, neighbor, risk, rho,
+ leastFavFct <- function(r, L2Fam, neighbor, risk, rho,
z.start, A.start, upper.b, MaxIter, eps, warn){
loRad <- r*rho
upRad <- r/rho
@@ -167,7 +166,7 @@
res <- getIneffDiff(x, L2Fam = L2Fam, neighbor = neighbor,
z.start = z.start, A.start = A.start, upper.b = upper.b, risk = risk,
loRad = loRad, upRad = upRad, loRisk = loRisk, upRisk = upRisk,
- eps = .Machine$double.eps^0.25, MaxIter = MaxIter, warn = warn)
+ eps = eps, MaxIter = MaxIter, warn = warn)
ineff <<- res["ineff"]
return(res["ineffDiff"])
}
@@ -188,7 +187,7 @@
}
if(is.null(A.start)) A.start <- L2Fam at param@trafo
- leastFavR <- optimize(leastFavFct.p, lower = 1e-4, upper = upRad,
+ leastFavR <- optimize(leastFavFct, lower = 1e-4, upper = upRad,
tol = .Machine$double.eps^0.25, maximum = TRUE,
L2Fam = L2Fam, neighbor = neighbor, risk = risk,
rho = rho, z.start = z.start, A.start = A.start,
Modified: branches/robast-1.2/pkg/ROptRegTS/R/radiusMinimaxIC.R
===================================================================
--- branches/robast-1.2/pkg/ROptRegTS/R/radiusMinimaxIC.R 2018-07-24 12:19:48 UTC (rev 1052)
+++ branches/robast-1.2/pkg/ROptRegTS/R/radiusMinimaxIC.R 2018-07-24 12:36:46 UTC (rev 1053)
@@ -63,15 +63,15 @@
ineff <- NULL
getIneffDiff.1 <- function(x){
- res <- getIneffDiff(x, L2Fam = L2Fam, neighbor = neighbor,
+ res <- getIneffDiff(x, L2Fam = L2Fam, neighbor = neighbor,
upper.b = upper.b, risk = risk, loRad = loRad, upRad = upRad,
loRisk = loRisk, upRisk = upRisk, eps = .Machine$double.eps^0.25,
MaxIter = maxiter, warn = warn)
- ineff <<- res["ineff"]
- return(res["ineffDiff"])
+ ineff <<- res["ineff"]
+ return(res["ineffDiff"])
}
leastFavR <- uniroot(getIneffDiff.1, lower = lower, upper = upper,
- tol = .Machine$double.eps^0.25)$root
+ tol = .Machine$double.eps^0.25)$root
neighbor at radius <- leastFavR
res <- getInfRobRegTypeIC(ErrorL2deriv = L2Fam at ErrorL2derivDistr[[1]],
Regressor = L2Fam at RegDistr, risk = risk, neighbor = neighbor,
@@ -160,15 +160,15 @@
ineff <- NULL
getIneffDiff.p <- function(x){
- res <- getIneffDiff(x, L2Fam = L2Fam, neighbor = neighbor,
+ res <- getIneffDiff(x, L2Fam = L2Fam, neighbor = neighbor,
z.start = z.start, A.start = A.start, upper.b = upper.b, risk = risk,
loRad = loRad, upRad = upRad, loRisk = loRisk, upRisk = upRisk,
eps = .Machine$double.eps^0.25, MaxIter = maxiter, warn = warn)
- ineff <<- res["ineff"]
- return(res["ineffDiff"])
- }
+ ineff <<- res["ineff"]
+ return(res["ineffDiff"])
+ }
leastFavR <- uniroot(getIneffDiff.p, lower = lower, upper = upper,
- tol = .Machine$double.eps^0.25)$root
+ tol = .Machine$double.eps^0.25)$root
neighbor at radius <- leastFavR
res <- getInfRobRegTypeIC(ErrorL2deriv = ErrorL2deriv,
Regressor = L2Fam at RegDistr, risk = risk, neighbor = neighbor,
Modified: pkg/ROptRegTS/R/ContIC.R
===================================================================
--- pkg/ROptRegTS/R/ContIC.R 2018-07-24 12:19:48 UTC (rev 1052)
+++ pkg/ROptRegTS/R/ContIC.R 2018-07-24 12:36:46 UTC (rev 1053)
@@ -1,51 +1,7 @@
-## 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){
- 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(L2Fam at param@trafo), 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
-
- 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))
-}
-
## generate IC
## for internal use only!
setMethod("generateIC", signature(neighbor = "ContNeighborhood",
- L2Fam = "L2ParamFamily"),
+ L2Fam = "L2RegTypeFamily"),
function(neighbor, L2Fam, res){
A <- res$A
a <- res$a
@@ -56,13 +12,13 @@
Y <- as(A %*% L2Fam at L2deriv - a, "EuclRandVariable")
if(nrvalues == 1){
if(!is.null(d)){
- ICfct[[1]] <- function(x){}#
- #ind <- (Y(x) != 0)
- # b*(ind*Y(x)/(ind*absY(x) + (1-ind)) + zi*(1-ind)*d)
- #}
+ ICfct[[1]] <- function(x){}
+ # ind <- (Y(x) != 0)
+ # b*(ind*Y(x)/(ind*absY(x) + (1-ind)*1) + zi*(1-ind)*d)
+ # }
body(ICfct[[1]]) <- substitute(
{ ind <- (Y(x) != 0)
- b*(ind*Y(x)/(ind*absY(x) + (1-ind)) + zi*(1-ind)*d) },
+ b*(ind*Y(x)/(ind*absY(x) + (1-ind)*1) + zi*(1-ind)*d) },
list(Y = Y at Map[[1]], absY = abs(Y)@Map[[1]], b = b, d = d,
zi = sign(L2Fam at param@trafo)))
}else{
@@ -70,7 +26,8 @@
body(ICfct[[1]]) <- substitute({ Y(x)*pmin(1, b/absY(x)) },
list(Y = Y at Map[[1]], absY = abs(Y)@Map[[1]], b = b))
}
- }else{
+ }
+ else{
absY <- sqrt(Y %*% Y)
if(!is.null(d))
for(i in 1:nrvalues){
@@ -86,17 +43,21 @@
}
}
return(ContIC(
- name = "IC of contamination type",
- CallL2Fam = call("L2ParamFamily",
+ name = "IC of contamination type",
+ CallL2Fam = call("L2RegTypeFamily",
name = L2Fam at name,
- distribution = L2Fam at distribution,
- distrSymm = L2Fam at distrSymm,
+ distribution = L2Fam at distribution,
param = L2Fam at param,
props = L2Fam at props,
+ ErrorDistr = L2Fam at ErrorDistr,
+ ErrorSymm = L2Fam at ErrorSymm,
+ RegDistr = L2Fam at RegDistr,
+ RegSymm = L2Fam at RegSymm,
+ Regressor = L2Fam at Regressor,
L2deriv = L2Fam at L2deriv,
- L2derivSymm = L2Fam at L2derivSymm,
- L2derivDistr = L2Fam at L2derivDistr,
- L2derivDistrSymm = L2Fam at L2derivDistrSymm,
+ ErrorL2deriv = L2Fam at ErrorL2deriv,
+ ErrorL2derivDistr = L2Fam at ErrorL2derivDistr,
+ ErrorL2derivSymm = L2Fam at ErrorL2derivSymm,
FisherInfo = L2Fam at FisherInfo),
Curve = EuclRandVarList(EuclRandVariable(Map = ICfct, Domain = Y at Domain,
Range = Y at Range)),
@@ -109,80 +70,3 @@
Infos = matrix(res$info, ncol = 2,
dimnames = list(character(0), c("method", "message")))))
})
-
-## Access methods
-setMethod("clip", "ContIC", function(object) object at clip)
-setMethod("cent", "ContIC", function(object) object at cent)
-setMethod("stand", "ContIC", function(object) object at stand)
-setMethod("lowerCase", "ContIC", function(object) object at lowerCase)
-setMethod("neighborRadius", "ContIC", function(object) object at neighborRadius)
-
-## replace methods
-setReplaceMethod("clip", "ContIC",
- function(object, value){
- stopifnot(is.numeric(value))
- L2Fam <- eval(object at CallL2Fam)
- res <- list(A = object at stand, a = object at cent, b = value, d = object at lowerCase,
- risk = object at Risks, info = object at Infos)
- 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)
- res <- list(A = object at stand, a = value, b = object at clip, d = object at lowerCase,
- risk = object at Risks, info = object at Infos)
- 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)
- res <- list(A = value, a = object at cent, b = object at clip, d = object at lowerCase,
- risk = object at Risks, info = object at Infos)
- object <- generateIC(neighbor = ContNeighborhood(radius = object at 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 at CallL2Fam)
- res <- list(A = object at stand, a = object at cent, b = object at clip, d = value,
- risk = object at Risks, info = object at Infos)
- object <- generateIC(neighbor = ContNeighborhood(radius = object at 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("neighborRadius", "ContIC",
- function(object, value){
- object at neighborRadius <- value
- if(any(value < 0)) # radius vector?!
- stop("'value' has to be in [0, Inf]")
- addInfo(object) <- c("neighborRadius<-", "The slot 'neighborRadius' has been changed")
- addInfo(object) <- c("neighborRadius<-", "The entries in 'Risks' and 'Infos' may be wrong")
- object
- })
-setReplaceMethod("CallL2Fam", "ContIC",
- function(object, value){
- L2Fam <- eval(value)
- res <- list(A = object at stand, a = object at cent, b = object at clip, d = object at lowerCase,
- risk = object at Risks, info = object at Infos)
- object <- generateIC(neighbor = ContNeighborhood(radius = object at 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
- })
Modified: pkg/ROptRegTS/R/getIneffDiff.R
===================================================================
--- pkg/ROptRegTS/R/getIneffDiff.R 2018-07-24 12:19:48 UTC (rev 1052)
+++ pkg/ROptRegTS/R/getIneffDiff.R 2018-07-24 12:36:46 UTC (rev 1053)
@@ -22,13 +22,12 @@
ineffUp <- res$b^2/upRisk
else
ineffUp <- (sum(diag(res$A %*% t(trafo))) - res$b^2*(radius^2-upRad^2))/upRisk
-## changed: shakey... assign("ineff", ineffUp, envir = sys.frame(which = -4))
-# return(ineffUp - ineffLo)
- return(c(ineff=ineffUp,ineffDiff=ineffUp - ineffLo))
- }else{
+ assign("ineff", ineffUp, envir = sys.frame(which = -4))
if(is(L2Fam at RegDistr, "MultivariateDistribution"))
cat("current radius:\t", radius, "\tMSE-inefficiency difference:\t", ineffUp - ineffLo, "\n")
+ return(ineffUp - ineffLo)
+ }else{
if(is(L2Fam at ErrorDistr, "UnivariateDistribution")){
if((length(L2Fam at ErrorL2deriv) == 1)
& is(L2Fam at ErrorL2deriv[[1]], "RealRandVariable")){
@@ -65,11 +64,11 @@
ineffUp <- res$b^2/upRisk
else
ineffUp <- (sum(diag(res$A%*%t(trafo))) - res$b^2*(radius^2-upRad^2))/upRisk
- ## changed: shakey assign("ineff", ineffUp, envir = sys.frame(which = -4))
+# assign("ineff", ineffUp, envir = sys.frame(which = -4))
+
cat("current radius:\t", radius, "\tMSE-inefficiency difference:\t", ineffUp - ineffLo, "\n")
-
- ## return(ineffUp - ineffLo)
- return(c(ineff=ineffUp,ineffDiff=ineffUp - ineffLo))
+ return(c(ineff=ineffUp, ineffDiff=ineffUp-ineffLo))
+# return(ineffUp - ineffLo)
}else{
stop("not yet implemented")
}
@@ -97,10 +96,11 @@
ineffUp <- res$b^2/upRisk
else
ineffUp <- (res$A*sum(diag(t(trafo) %*% K.inv)) - res$b^2*(radius^2-upRad^2))/upRisk
- assign("ineff", ineffUp, envir = sys.frame(which = -4))
+# assign("ineff", ineffUp, envir = sys.frame(which = -4))
# cat("current radius:\t", radius, "\tMSE-inefficiency difference:\t", ineffUp - ineffLo, "\n")
- return(ineffUp - ineffLo)
+ return(c(ineff=ineffUp, ineffDiff=ineffUp-ineffLo))
+# return(ineffUp - ineffLo)
}else{
stop("not yet implemented")
}
Modified: pkg/ROptRegTS/R/leastFavorableRadius.R
===================================================================
--- pkg/ROptRegTS/R/leastFavorableRadius.R 2018-07-24 12:19:48 UTC (rev 1052)
+++ pkg/ROptRegTS/R/leastFavorableRadius.R 2018-07-24 12:36:46 UTC (rev 1053)
@@ -63,12 +63,11 @@
clip = resUp$b, cent = resUp$a, stand = resUp$A,
trafo = L2Fam at param@trafo)[[1]]
}
-
ineff <- NULL
getIneffDiff.1 <- function(x){
res <- getIneffDiff(x, L2Fam = L2Fam, neighbor = neighbor,
upper.b = upper.b, risk = risk, loRad = loRad, upRad = upRad,
- loRisk = loRisk, upRisk = upRisk, eps = .Machine$double.eps^0.25,
+ loRisk = loRisk, upRisk = upRisk, eps = eps,
MaxIter = MaxIter, warn = warn)
ineff <<- res["ineff"]
return(res["ineffDiff"])
@@ -111,7 +110,7 @@
ErrorL2derivDistrSymm <- new("DistrSymmList", L2)
}
}
- leastFavFct.p <- function(r, L2Fam, neighbor, risk, rho,
+ leastFavFct <- function(r, L2Fam, neighbor, risk, rho,
z.start, A.start, upper.b, MaxIter, eps, warn){
loRad <- r*rho
upRad <- r/rho
@@ -167,7 +166,7 @@
res <- getIneffDiff(x, L2Fam = L2Fam, neighbor = neighbor,
z.start = z.start, A.start = A.start, upper.b = upper.b, risk = risk,
loRad = loRad, upRad = upRad, loRisk = loRisk, upRisk = upRisk,
- eps = .Machine$double.eps^0.25, MaxIter = MaxIter, warn = warn)
+ eps = eps, MaxIter = MaxIter, warn = warn)
ineff <<- res["ineff"]
return(res["ineffDiff"])
}
@@ -188,7 +187,7 @@
}
if(is.null(A.start)) A.start <- L2Fam at param@trafo
- leastFavR <- optimize(leastFavFct.p, lower = 1e-4, upper = upRad,
+ leastFavR <- optimize(leastFavFct, lower = 1e-4, upper = upRad,
tol = .Machine$double.eps^0.25, maximum = TRUE,
L2Fam = L2Fam, neighbor = neighbor, risk = risk,
rho = rho, z.start = z.start, A.start = A.start,
Modified: pkg/ROptRegTS/R/radiusMinimaxIC.R
===================================================================
--- pkg/ROptRegTS/R/radiusMinimaxIC.R 2018-07-24 12:19:48 UTC (rev 1052)
+++ pkg/ROptRegTS/R/radiusMinimaxIC.R 2018-07-24 12:36:46 UTC (rev 1053)
@@ -63,15 +63,15 @@
ineff <- NULL
getIneffDiff.1 <- function(x){
- res <- getIneffDiff(x, L2Fam = L2Fam, neighbor = neighbor,
+ res <- getIneffDiff(x, L2Fam = L2Fam, neighbor = neighbor,
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/robast -r 1053
More information about the Robast-commits
mailing list