[Robast-commits] r962 - in branches/robast-1.1/pkg/ROptRegTS: . R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Jul 17 15:55:35 CEST 2018
Author: ruckdeschel
Date: 2018-07-17 15:55:34 +0200 (Tue, 17 Jul 2018)
New Revision: 962
Modified:
branches/robast-1.1/pkg/ROptRegTS/DESCRIPTION
branches/robast-1.1/pkg/ROptRegTS/NAMESPACE
branches/robast-1.1/pkg/ROptRegTS/R/Av1CondContIC.R
branches/robast-1.1/pkg/ROptRegTS/R/Av1CondTotalVarIC.R
branches/robast-1.1/pkg/ROptRegTS/R/Av2CondContIC.R
branches/robast-1.1/pkg/ROptRegTS/R/CondContIC.R
branches/robast-1.1/pkg/ROptRegTS/R/CondIC.R
branches/robast-1.1/pkg/ROptRegTS/R/CondTotalVarIC.R
branches/robast-1.1/pkg/ROptRegTS/R/ContIC.R
branches/robast-1.1/pkg/ROptRegTS/R/getAsRiskRegTS.R
branches/robast-1.1/pkg/ROptRegTS/R/getIneffDiff.R
branches/robast-1.1/pkg/ROptRegTS/R/getInfCentRegTS.R
branches/robast-1.1/pkg/ROptRegTS/R/getInfClipRegTS.R
branches/robast-1.1/pkg/ROptRegTS/R/getInfGammaRegTS.R
branches/robast-1.1/pkg/ROptRegTS/R/getInfRobRegTypeIC_asBias.R
branches/robast-1.1/pkg/ROptRegTS/R/getInfStandRegTS.R
branches/robast-1.1/pkg/ROptRegTS/R/leastFavorableRadius.R
branches/robast-1.1/pkg/ROptRegTS/R/radiusMinimaxIC.R
Log:
[ROptRegTS] branch 1.1 some NAMESPACE items added, some unbound variables, changed shakey call to sys.frame(...)
Modified: branches/robast-1.1/pkg/ROptRegTS/DESCRIPTION
===================================================================
--- branches/robast-1.1/pkg/ROptRegTS/DESCRIPTION 2018-07-17 12:26:22 UTC (rev 961)
+++ branches/robast-1.1/pkg/ROptRegTS/DESCRIPTION 2018-07-17 13:55:34 UTC (rev 962)
@@ -1,12 +1,12 @@
Package: ROptRegTS
Version: 1.1.0
-Date: 2018-07-08
+Date: 2018-07-17
Title: Optimally Robust Estimation for Regression-Type Models
Description: Optimally robust estimation for regression-type models using S4 classes and
methods.
Depends: R (>= 2.14.0), methods, ROptEstOld(>= 0.9.1)
Imports: distr(>= 2.5.2), distrEx(>= 2.5), RandVar(>= 0.9.2)
-Authors at R: c(person("Matthias", "Kohl", role=c("cre", "cph"),
+Authors at R: c(person("Matthias", "Kohl", role=c("cre", "aut", "cph"),
email="Matthias.Kohl at stamats.de"), person("Peter", "Ruckdeschel", role=c("aut",
"cph")))
ByteCompile: yes
Modified: branches/robast-1.1/pkg/ROptRegTS/NAMESPACE
===================================================================
--- branches/robast-1.1/pkg/ROptRegTS/NAMESPACE 2018-07-17 12:26:22 UTC (rev 961)
+++ branches/robast-1.1/pkg/ROptRegTS/NAMESPACE 2018-07-17 13:55:34 UTC (rev 962)
@@ -3,6 +3,8 @@
import("distrEx")
import("RandVar")
import("ROptEstOld")
+importFrom("stats", "approxfun", "dbinom", "fft", "optim", "optimize",
+ "pbinom", "pnorm", "uniroot")
exportClasses("RegTypeFamily",
"L2RegTypeFamily")
Modified: branches/robast-1.1/pkg/ROptRegTS/R/Av1CondContIC.R
===================================================================
--- branches/robast-1.1/pkg/ROptRegTS/R/Av1CondContIC.R 2018-07-17 12:26:22 UTC (rev 961)
+++ branches/robast-1.1/pkg/ROptRegTS/R/Av1CondContIC.R 2018-07-17 13:55:34 UTC (rev 962)
@@ -34,17 +34,17 @@
Y <- as(A %*% L2Fam at L2deriv, "EuclRandVariable") - a1
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)) + 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) },
list(Y = Y at Map[[1]], absY = abs(Y)@Map[[1]], b = b, d = d,
zi = sign(L2Fam at param@trafo)))
}else{
- ICfct[[1]] <- function(x){ Y(x)*pmin(1, b/absY(x)) }
+ ICfct[[1]] <- function(x){}# Y(x)*pmin(1, b/absY(x)) }
body(ICfct[[1]]) <- substitute({ Y(x)*pmin(1, b/absY(x)) },
list(Y = Y at Map[[1]], absY = abs(Y)@Map[[1]], b = b))
}
@@ -52,13 +52,13 @@
absY <- sqrt(Y %*% Y)
if(!is.null(d))
for(i in 1:nrvalues){
- ICfct[[i]] <- function(x){ ind <- (Yi(x) != 0) ; ind*b*Yi(x)/absY(x) + (1-ind)*d }
+ ICfct[[i]] <- function(x){}# ind <- (Yi(x) != 0) ; ind*b*Yi(x)/absY(x) + (1-ind)*d }
body(ICfct[[i]]) <- substitute({ ind <- (Yi(x) != 0) ; ind*b*Yi(x)/absY(x) + (1-ind)*d },
list(Yi = Y at Map[[i]], absY = absY at Map[[1]], b = b, d = d[i]))
}
else
for(i in 1:nrvalues){
- ICfct[[i]] <- function(x){ Yi(x)*pmin(1, b/absY(x)) }
+ ICfct[[i]] <- function(x){}# Yi(x)*pmin(1, b/absY(x)) }
body(ICfct[[i]]) <- substitute({ Yi(x)*pmin(1, b/absY(x)) },
list(Yi = Y at Map[[i]], absY = absY at Map[[1]], b = b))
}
Modified: branches/robast-1.1/pkg/ROptRegTS/R/Av1CondTotalVarIC.R
===================================================================
--- branches/robast-1.1/pkg/ROptRegTS/R/Av1CondTotalVarIC.R 2018-07-17 12:26:22 UTC (rev 961)
+++ branches/robast-1.1/pkg/ROptRegTS/R/Av1CondTotalVarIC.R 2018-07-17 13:55:34 UTC (rev 962)
@@ -32,13 +32,13 @@
L2 <- L2Fam at ErrorL2deriv[[1]]
k <- dimension(img(L2Fam at RegDistr))
if(!is.null(d)){
- ICfct[[1]] <- function(x){ ind1 <- (L2(x[k+1]) > 0); ind2 <- (L2(x[k+1]) < 0)
- A <- matrix(A.vec, ncol = k)
- Y <- as.vector(A %*% x[1:k])
- v <- sqrt(sum(Y^2))
- ax <- a(x[1:k])
- Y/v*((ax+b)*ind1 + ax*ind2)
- }
+ ICfct[[1]] <- function(x){}# ind1 <- (L2(x[k+1]) > 0); ind2 <- (L2(x[k+1]) < 0)
+ # A <- matrix(A.vec, ncol = k)
+ # Y <- as.vector(A %*% x[1:k])
+ # v <- sqrt(sum(Y^2))
+ # ax <- a(x[1:k])
+ # Y/v*((ax+b)*ind1 + ax*ind2)
+ # }
body(ICfct[[1]]) <- substitute({ ind1 <- (L2(x[k+1]) > 0); ind2 <- (L2(x[k+1]) < 0)
A <- matrix(A.vec, ncol = k)
Y <- as.vector(A %*% x[1:k])
@@ -49,13 +49,13 @@
b = b, k = k))
}else{
if(b == Inf){
- ICfct[[1]]<- function(x){ A <- matrix(A.vec, ncol = k)
- v <- as.vector(sqrt(sum((A %*% x[1:k])^2)))
- ax <- a(x[1:k])
- if(ax == -Inf)
- as.vector(A %*% x[1:k])*L2(x[k+1])
- else
- as.vector(A %*% x[1:k])*max(a(x[1:k])/v, L2(x[k+1])) }
+ ICfct[[1]]<- function(x){}# A <- matrix(A.vec, ncol = k)
+ # v <- as.vector(sqrt(sum((A %*% x[1:k])^2)))
+ # ax <- a(x[1:k])
+ # if(ax == -Inf)
+ # as.vector(A %*% x[1:k])*L2(x[k+1])
+ # else
+ # as.vector(A %*% x[1:k])*max(a(x[1:k])/v, L2(x[k+1])) }
body(ICfct[[1]]) <- substitute({ A <- matrix(A.vec, ncol = k)
v <- as.vector(sqrt(sum((A %*% x[1:k])^2)))
ax <- a(x[1:k])
@@ -66,10 +66,10 @@
list(A.vec = as.vector(A), L2 = L2 at Map[[1]], a = a at Map[[1]],
b = b, k = k))
}else{
- ICfct[[1]] <- function(x){ A <- matrix(A.vec, ncol = k)
- v <- as.vector(sqrt(sum((A %*% x[1:k])^2)))
- ax <- a(x[1:k])
- as.vector(A %*% x[1:k])*min(max(a(x[1:k])/v, L2(x[k+1])), (ax+b)/v) }
+ ICfct[[1]] <- function(x){}# A <- matrix(A.vec, ncol = k)
+ # v <- as.vector(sqrt(sum((A %*% x[1:k])^2)))
+ # ax <- a(x[1:k])
+ # as.vector(A %*% x[1:k])*min(max(a(x[1:k])/v, L2(x[k+1])), (ax+b)/v) }
body(ICfct[[1]]) <- substitute({ A <- matrix(A.vec, ncol = k)
v <- as.vector(sqrt(sum((A %*% x[1:k])^2)))
ax <- a(x[1:k])
Modified: branches/robast-1.1/pkg/ROptRegTS/R/Av2CondContIC.R
===================================================================
--- branches/robast-1.1/pkg/ROptRegTS/R/Av2CondContIC.R 2018-07-17 12:26:22 UTC (rev 961)
+++ branches/robast-1.1/pkg/ROptRegTS/R/Av2CondContIC.R 2018-07-17 13:55:34 UTC (rev 962)
@@ -34,12 +34,12 @@
if(!is.null(d)){
b0 <- b/sqrt(sum(diag(trafo %*% K.inv %*% t(trafo))))
- ICfct[[1]] <- function(x){
- ind <- (L2(x[k+1]) != z)
- D <- matrix(D.vec, ncol = k)
- K.inv <- matrix(K.vec, ncol = k)
- b0*D %*% K.inv %*% x[1:k]*(sign(L2(x[k+1]) - z) + (1-ind)*d)
- }
+ ICfct[[1]] <- function(x){}
+ # ind <- (L2(x[k+1]) != z)
+ # D <- matrix(D.vec, ncol = k)
+ # K.inv <- matrix(K.vec, ncol = k)
+ # b0*D %*% K.inv %*% x[1:k]*(sign(L2(x[k+1]) - z) + (1-ind)*d)
+ # }
body(ICfct[[1]]) <- substitute(
{ ind <- (L2(x[k+1]) != z)
D <- matrix(D.vec, ncol = k)
@@ -49,10 +49,10 @@
K.vec = as.vector(K.inv), b0 = b0, d = d, k = k))
}else{
c0 <- b/(A*sqrt(sum(diag(K.inv))))
- ICfct[[1]] <- function(x){ D <- matrix(D.vec, ncol = k)
- K.inv <- matrix(K.vec, ncol = k)
- A*D %*% K.inv %*% x[1:k]*(L2(x[k+1]) - z)*pmin(1, c0/abs(L2(x[k+1]) - z))
- }
+ ICfct[[1]] <- function(x){}# D <- matrix(D.vec, ncol = k)
+ # K.inv <- matrix(K.vec, ncol = k)
+ # A*D %*% K.inv %*% x[1:k]*(L2(x[k+1]) - z)*pmin(1, c0/abs(L2(x[k+1]) - z))
+ #}
body(ICfct[[1]]) <- substitute({ D <- matrix(D.vec, ncol = k)
K.inv <- matrix(K.vec, ncol = k)
A*D %*% K.inv %*% x[1:k]*(L2(x[k+1]) - z)*pmin(1, c0/abs(L2(x[k+1]) - z)) },
Modified: branches/robast-1.1/pkg/ROptRegTS/R/CondContIC.R
===================================================================
--- branches/robast-1.1/pkg/ROptRegTS/R/CondContIC.R 2018-07-17 12:26:22 UTC (rev 961)
+++ branches/robast-1.1/pkg/ROptRegTS/R/CondContIC.R 2018-07-17 13:55:34 UTC (rev 962)
@@ -38,17 +38,17 @@
k <- dimension(img(L2Fam at RegDistr))
if(nrvalues == 1){
if(!is.null(d)){
- ICfct[[1]] <- function(x){
- ind <- (Y(x) != 0)
- b(x[1:k])*(ind*Y(x)/(ind*absY(x) + (1-ind)) + zi*(1-ind)*d)
- }
+ ICfct[[1]] <- function(x){}
+ # ind <- (Y(x) != 0)
+ # b(x[1:k])*(ind*Y(x)/(ind*absY(x) + (1-ind)) + zi*(1-ind)*d)
+ #}
body(ICfct[[1]]) <- substitute(
{ ind <- (Y(x) != 0)
b(x[1:k])*(ind*Y(x)/(ind*absY(x) + (1-ind)) + zi*(1-ind)*d) },
list(Y = Y at Map[[1]], absY = abs(Y)@Map[[1]], b = b at Map[[1]], d = d,
zi = sign(L2Fam at param@trafo), k = k))
}else{
- ICfct[[1]] <- function(x){ Y(x)*pmin(1, b(x[1:k])/absY(x)) }
+ ICfct[[1]] <- function(x){}# Y(x)*pmin(1, b(x[1:k])/absY(x)) }
body(ICfct[[1]]) <- substitute({ Y(x)*pmin(1, b(x[1:k])/absY(x)) },
list(Y = Y at Map[[1]], absY = abs(Y)@Map[[1]],
b = b at Map[[1]], k = k))
@@ -57,14 +57,14 @@
absY <- sqrt(Y %*% Y)
if(!is.null(d))
for(i in 1:nrvalues){
- ICfct[[i]] <- function(x){ ind <- (Yi(x) != 0) ; ind*b(x[1:k])*Yi(x)/absY(x) + (1-ind)*d }
+ ICfct[[i]] <- function(x){}# ind <- (Yi(x) != 0) ; ind*b(x[1:k])*Yi(x)/absY(x) + (1-ind)*d }
body(ICfct[[i]]) <- substitute({ ind <- (Yi(x) != 0) ; ind*b(x[1:k])*Yi(x)/absY(x) + (1-ind)*d },
list(Yi = Y at Map[[i]], absY = absY at Map[[1]], b = b at Map[[1]],
d = d[i], k = k))
}
else
for(i in 1:nrvalues){
- ICfct[[i]] <- function(x){ Yi(x)*pmin(1, b(x[1:k])/absY(x)) }
+ ICfct[[i]] <- function(x){}# Yi(x)*pmin(1, b(x[1:k])/absY(x)) }
body(ICfct[[i]]) <- substitute({ Yi(x)*pmin(1, b(x[1:k])/absY(x)) },
list(Yi = Y at Map[[i]], absY = absY at Map[[1]], b = b at Map[[1]], k = k))
}
Modified: branches/robast-1.1/pkg/ROptRegTS/R/CondIC.R
===================================================================
--- branches/robast-1.1/pkg/ROptRegTS/R/CondIC.R 2018-07-17 12:26:22 UTC (rev 961)
+++ branches/robast-1.1/pkg/ROptRegTS/R/CondIC.R 2018-07-17 13:55:34 UTC (rev 962)
@@ -26,6 +26,7 @@
function(IC, out = TRUE){
L2Fam <- eval(IC at CallL2Fam)
K <- L2Fam at RegDistr
+ TruncQuantile <- getdistrOption("TruncQuantile")
if(is(K, "DiscreteDistribution") || is(K, "DiscreteMVDistribution"))
cond <- as.matrix(support(K))
else{
@@ -74,6 +75,7 @@
setMethod("checkIC", signature(IC = "CondIC", L2Fam = "L2RegTypeFamily"),
function(IC, L2Fam, out = TRUE){
K <- L2Fam at RegDistr
+ TruncQuantile <- getdistrOption("TruncQuantile")
if(is(K, "DiscreteDistribution") || is(K, "DiscreteMVDistribution"))
cond <- as.matrix(support(K))
else{
Modified: branches/robast-1.1/pkg/ROptRegTS/R/CondTotalVarIC.R
===================================================================
--- branches/robast-1.1/pkg/ROptRegTS/R/CondTotalVarIC.R 2018-07-17 12:26:22 UTC (rev 961)
+++ branches/robast-1.1/pkg/ROptRegTS/R/CondTotalVarIC.R 2018-07-17 13:55:34 UTC (rev 962)
@@ -34,11 +34,11 @@
L2 <- L2Fam at ErrorL2deriv[[1]]
k <- dimension(img(L2Fam at RegDistr))
if(!is.null(d)){
- ICfct[[1]] <- function(x){ A <- matrix(A.vec, ncol = k)
- Y <- as.vector(A %*% x[1:k]) * L2(x[k+1])
- ind1 <- (Y > 0); ind2 <- (Y < 0)
- b(x[1:k])*ind1 + a(x[1:k])*ind2
- }
+ ICfct[[1]] <- function(x){}# A <- matrix(A.vec, ncol = k)
+ # Y <- as.vector(A %*% x[1:k]) * L2(x[k+1])
+ # ind1 <- (Y > 0); ind2 <- (Y < 0)
+ # b(x[1:k])*ind1 + a(x[1:k])*ind2
+ # }
body(ICfct[[1]]) <- substitute({ A <- matrix(A.vec, ncol = k)
Y <- as.vector(A %*% x[1:k]) * L2(x[k+1])
ind1 <- (Y > 0); ind2 <- (Y < 0)
@@ -46,9 +46,9 @@
list(A.vec = as.vector(A), L2 = L2 at Map[[1]], a = a at Map[[1]],
b = b at Map[[1]], k = k))
}else{
- ICfct[[1]]<- function(x){ A <- matrix(A.vec, ncol = k)
- Y <- as.vector(A %*% x[1:k]) * L2(x[k+1])
- min(max(a(x[1:k]), Y), b(x[1:k])) }
+ ICfct[[1]]<- function(x){}# A <- matrix(A.vec, ncol = k)
+ # Y <- as.vector(A %*% x[1:k]) * L2(x[k+1])
+ # min(max(a(x[1:k]), Y), b(x[1:k])) }
body(ICfct[[1]]) <- substitute({ A <- matrix(A.vec, ncol = k)
Y <- as.vector(A %*% x[1:k]) * L2(x[k+1])
min(max(a(x[1:k]), Y), b(x[1:k])) },
Modified: branches/robast-1.1/pkg/ROptRegTS/R/ContIC.R
===================================================================
--- branches/robast-1.1/pkg/ROptRegTS/R/ContIC.R 2018-07-17 12:26:22 UTC (rev 961)
+++ branches/robast-1.1/pkg/ROptRegTS/R/ContIC.R 2018-07-17 13:55:34 UTC (rev 962)
@@ -12,17 +12,17 @@
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)*1) + 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)*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{
- ICfct[[1]] <- function(x){ Y(x)*pmin(1, b/absY(x)) }
+ ICfct[[1]] <- function(x){}# Y(x)*pmin(1, b/absY(x)) }
body(ICfct[[1]]) <- substitute({ Y(x)*pmin(1, b/absY(x)) },
list(Y = Y at Map[[1]], absY = abs(Y)@Map[[1]], b = b))
}
@@ -31,13 +31,13 @@
absY <- sqrt(Y %*% Y)
if(!is.null(d))
for(i in 1:nrvalues){
- ICfct[[i]] <- function(x){ ind <- (Yi(x) != 0) ; ind*b*Yi(x)/absY(x) + (1-ind)*d }
+ ICfct[[i]] <- function(x){}# ind <- (Yi(x) != 0) ; ind*b*Yi(x)/absY(x) + (1-ind)*d }
body(ICfct[[i]]) <- substitute({ ind <- (Yi(x) != 0) ; ind*b*Yi(x)/absY(x) + (1-ind)*d },
list(Yi = Y at Map[[i]], absY = absY at Map[[1]], b = b, d = d[i]))
}
else
for(i in 1:nrvalues){
- ICfct[[i]] <- function(x){ Yi(x)*pmin(1, b/absY(x)) }
+ ICfct[[i]] <- function(x){}# Yi(x)*pmin(1, b/absY(x)) }
body(ICfct[[i]]) <- substitute({ Yi(x)*pmin(1, b/absY(x)) },
list(Yi = Y at Map[[i]], absY = absY at Map[[1]], b = b))
}
Modified: branches/robast-1.1/pkg/ROptRegTS/R/getAsRiskRegTS.R
===================================================================
--- branches/robast-1.1/pkg/ROptRegTS/R/getAsRiskRegTS.R 2018-07-17 12:26:22 UTC (rev 961)
+++ branches/robast-1.1/pkg/ROptRegTS/R/getAsRiskRegTS.R 2018-07-17 13:55:34 UTC (rev 962)
@@ -50,6 +50,7 @@
zi <- sign(as.vector(trafo))
A <- as.matrix(zi)
+ upper <- q.l(ErrorL2deriv)(1-getdistrOption("TruncQuantile"))
if(z.comp){
abs.fct <- function(x, ErrorL2deriv, cent){
abs(x)*E(ErrorL2deriv, function(u, xx, cent){abs(u - cent/x)}, xx = x, cent = cent)
@@ -113,7 +114,7 @@
E(ErrorL2deriv, abs.fctu, xx = x, A = A, a0 = a0)
}
- bmin.fct <- function(param, ErrorL2deriv, Regressor, trafo){
+ bmin.fct.z <- function(param, ErrorL2deriv, Regressor, trafo){
p <- nrow(trafo)
k <- ncol(trafo)
A <- matrix(param[1:(p*k)], ncol=k, nrow=p)
@@ -122,7 +123,7 @@
return(E(Regressor, abs.fctx, ErrorL2deriv = ErrorL2deriv, A = A, a0 = a)/sum(diag(A %*% t(trafo))))
}
- erg <- optim(c(as.vector(trafo), numeric(nrow(trafo))), bmin.fct, method = "Nelder-Mead",
+ erg <- optim(c(as.vector(trafo), numeric(nrow(trafo))), bmin.fct.z, method = "Nelder-Mead",
control=list(reltol=tol, maxit=100*maxiter), Regressor = Regressor,
ErrorL2deriv = ErrorL2deriv, trafo = trafo)
b <- 1/erg$value
@@ -252,7 +253,7 @@
stop("not yet implemented")
- return(list(asBias = b))
+ return(list(asBias = NULL))
})
setMethod("getAsRiskRegTS", signature(risk = "asUnOvShoot",
ErrorL2deriv = "UnivariateDistribution",
Modified: branches/robast-1.1/pkg/ROptRegTS/R/getIneffDiff.R
===================================================================
--- branches/robast-1.1/pkg/ROptRegTS/R/getIneffDiff.R 2018-07-17 12:26:22 UTC (rev 961)
+++ branches/robast-1.1/pkg/ROptRegTS/R/getIneffDiff.R 2018-07-17 13:55:34 UTC (rev 962)
@@ -64,10 +64,11 @@
ineffUp <- res$b^2/upRisk
else
ineffUp <- (sum(diag(res$A%*%t(trafo))) - 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")
}
@@ -95,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.1/pkg/ROptRegTS/R/getInfCentRegTS.R
===================================================================
--- branches/robast-1.1/pkg/ROptRegTS/R/getInfCentRegTS.R 2018-07-17 12:26:22 UTC (rev 961)
+++ branches/robast-1.1/pkg/ROptRegTS/R/getInfCentRegTS.R 2018-07-17 13:55:34 UTC (rev 962)
@@ -23,6 +23,7 @@
Regressor = "UnivariateDistribution",
neighbor = "TotalVarNeighborhood"),
function(ErrorL2deriv, Regressor, neighbor, clip, cent, z.comp){
+ tol.z <- .Machine$double.eps^.25
if(!z.comp) return(-clip/2)
g.fct <- function(z, c0, D1, K){
@@ -42,8 +43,8 @@
lower <- q.l(ErrorL2deriv)(distr::TruncQuantile)
upper <- q.l(ErrorL2deriv)(1-distr::TruncQuantile)
- return(uniroot(g.fct, lower = lower, upper = upper, tol = tol.z,
- c0 = clip, D1 = D1, K = Regressor)$root)
+ return(uniroot(g.fct, lower = lower, upper = upper, tol = tol.z,
+ c0 = clip, D1 = ErrorL2deriv, K = Regressor)$root)
})
setMethod("getInfCentRegTS", signature(ErrorL2deriv = "UnivariateDistribution",
Regressor = "MultivariateDistribution",
@@ -83,8 +84,13 @@
Regressor = "numeric",
neighbor = "CondTotalVarNeighborhood"),
function(ErrorL2deriv, Regressor, neighbor, clip, cent, z.comp){
+
+ tol.z <- .Machine$double.eps^.25
+
if(!z.comp) return(-clip)
+ x <- Regressor
+ b <- clip/2
if(x > 0){
g.fct <- function(z, c0, D1, x){
z*p(D1)(z/x) - x*(m1df(D1, z/x) - m1df(D1, b/x)) + b*(1-p(D1)(b/x))
@@ -97,8 +103,8 @@
lower <- q.l(ErrorL2deriv)(distr::TruncQuantile)
upper <- q.l(ErrorL2deriv)(1-distr::TruncQuantile)
- return(uniroot(g.fct, lower = lower, upper = upper, tol = tol.z,
- c0 = clip, D1 = D1, x = Regressor)$root)
+ return(uniroot(g.fct, lower = lower, upper = upper, tol = tol.z,
+ c0 = clip, D1 = ErrorL2deriv, x = Regressor)$root)
})
setMethod("getInfCentRegTS", signature(ErrorL2deriv = "UnivariateDistribution",
Regressor = "UnivariateDistribution",
@@ -181,7 +187,7 @@
z.vec <- res2/res1
k <- dimension(img(Regressor))
if(is(Regressor, "DiscreteMVDistribution")){
- z.fct <- function(x){
+ z.fct <- function(x){
ind <- colSums(apply(round(x.vec, 8), 1, "==", round(x, 8))) == k
if(any(ind))
return(z.vec[ind])
@@ -214,7 +220,7 @@
neighbor = "Av1CondTotalVarNeighborhood"),
function(ErrorL2deriv, Regressor, neighbor, clip, cent, stand, z.comp, x.vec, tol.z){
if(!z.comp){
- z.fct <- function(x){-b/2}
+ z.fct <- function(x){}#-b/2}
body(z.fct) <- substitute({-b/2}, list(b = clip))
z.vec <- numeric(length(x.vec)) - clip/2
return(list(z.fct = z.fct, z.vec = z.vec))
@@ -263,7 +269,7 @@
neighbor = "Av1CondTotalVarNeighborhood"),
function(ErrorL2deriv, Regressor, neighbor, clip, cent, stand, z.comp, x.vec, tol.z){
if(!z.comp){
- z.fct <- function(x){ -b/2 }
+ z.fct <- function(x){}# -b/2 }
body(z.fct) <- substitute({ -b/2 }, list(b = clip))
z.vec <- numeric(nrow(as.matrix(x.vec))) - clip/2
return(list(z.fct = z.fct, z.vec = z.vec))
Modified: branches/robast-1.1/pkg/ROptRegTS/R/getInfClipRegTS.R
===================================================================
--- branches/robast-1.1/pkg/ROptRegTS/R/getInfClipRegTS.R 2018-07-17 12:26:22 UTC (rev 961)
+++ branches/robast-1.1/pkg/ROptRegTS/R/getInfClipRegTS.R 2018-07-17 13:55:34 UTC (rev 962)
@@ -19,7 +19,7 @@
neighbor = "Av1CondTotalVarNeighborhood"),
function(clip, ErrorL2deriv, Regressor, risk, neighbor, z.comp, stand, cent){
if(!z.comp){
- cent <- function(x){-b/2}
+ cent <- function(x){}#-b/2}
body(cent) <- substitute({-b/2}, list(b = clip))
return(neighbor at radius^2*clip +
getInfGammaRegTS(ErrorL2deriv = ErrorL2deriv,
Modified: branches/robast-1.1/pkg/ROptRegTS/R/getInfGammaRegTS.R
===================================================================
--- branches/robast-1.1/pkg/ROptRegTS/R/getInfGammaRegTS.R 2018-07-17 12:26:22 UTC (rev 961)
+++ branches/robast-1.1/pkg/ROptRegTS/R/getInfGammaRegTS.R 2018-07-17 13:55:34 UTC (rev 962)
@@ -24,7 +24,7 @@
neighbor = "ContNeighborhood"),
function(ErrorL2deriv, Regressor, risk, neighbor, z.comp, stand, cent, clip){
if(z.comp){
- Gfct <- function(x, stand, cent, clip, D1){
+ Gfct.z <- function(x, stand, cent, clip, D1){
Gfctu <- function(u, xx, stand, cent, clip){
v <- as.vector(stand %*% (xx*u - cent))
res <- as.vector(sqrt(v %*% v)) - clip
@@ -32,7 +32,7 @@
}
E(D1, Gfctu, xx = x, stand = stand, cent = cent, clip = clip)
}
- return(-E(Regressor, Gfct, stand = stand, cent = cent, clip = clip, D1 = ErrorL2deriv))
+ return(-E(Regressor, Gfct.z, stand = stand, cent = cent, clip = clip, D1 = ErrorL2deriv))
}else{
Gfct <- function(x, stand, clip, D1){
v <- t(x) %*% stand
@@ -64,7 +64,7 @@
neighbor = "Av1CondContNeighborhood"),
function(ErrorL2deriv, Regressor, risk, neighbor, z.comp, stand, cent, clip){
if(z.comp){
- Gfct <- function(x, stand, cent, clip, D1){
+ Gfct.z <- function(x, stand, cent, clip, D1){
Gfctu <- function(u, xx, stand, cent, clip){
v <- as.vector(stand %*% xx*(u - cent(xx)))
res <- as.vector(sqrt(v %*% v)) - clip
@@ -72,7 +72,7 @@
}
E(D1, Gfctu, xx = x, stand = stand, cent = cent, clip = clip)
}
- return(-E(Regressor, Gfct, stand = stand, cent = cent, clip = clip, D1 = ErrorL2deriv))
+ return(-E(Regressor, Gfct.z, stand = stand, cent = cent, clip = clip, D1 = ErrorL2deriv))
}else{
Gfct <- function(x, stand, clip, D1){
v <- t(x) %*% stand
Modified: branches/robast-1.1/pkg/ROptRegTS/R/getInfRobRegTypeIC_asBias.R
===================================================================
--- branches/robast-1.1/pkg/ROptRegTS/R/getInfRobRegTypeIC_asBias.R 2018-07-17 12:26:22 UTC (rev 961)
+++ branches/robast-1.1/pkg/ROptRegTS/R/getInfRobRegTypeIC_asBias.R 2018-07-17 13:55:34 UTC (rev 962)
@@ -183,7 +183,7 @@
E(ErrorL2deriv, abs.fctu, xx = x, A = A, a0 = a0)
}
- bmin.fct <- function(param, ErrorL2deriv, Regressor, trafo){
+ bmin.fct.z <- function(param, ErrorL2deriv, Regressor, trafo){
p <- nrow(trafo)
k <- ncol(trafo)
A <- matrix(param[1:(p*k)], ncol=k, nrow=p)
@@ -192,7 +192,7 @@
return(E(Regressor, abs.fctx, ErrorL2deriv = ErrorL2deriv, A = A, a0 = a)/sum(diag(A %*% t(trafo))))
}
- erg <- optim(c(as.vector(trafo), numeric(nrow(trafo))), bmin.fct, method = "Nelder-Mead",
+ erg <- optim(c(as.vector(trafo), numeric(nrow(trafo))), bmin.fct.z, method = "Nelder-Mead",
control=list(reltol=tol, maxit=100*maxiter), Regressor = Regressor,
ErrorL2deriv = ErrorL2deriv, trafo = trafo)
b <- 1/erg$value
@@ -372,5 +372,5 @@
stop("not yet implemented")
- return(list(A = A, a = a, b = b, d = 0*a, risk = Risk, info = info))
+ return(NULL) #list(A = A, a = a, b = b, d = 0*a, risk = Risk, info = info))
})
Modified: branches/robast-1.1/pkg/ROptRegTS/R/getInfStandRegTS.R
===================================================================
--- branches/robast-1.1/pkg/ROptRegTS/R/getInfStandRegTS.R 2018-07-17 12:26:22 UTC (rev 961)
+++ branches/robast-1.1/pkg/ROptRegTS/R/getInfStandRegTS.R 2018-07-17 13:55:34 UTC (rev 962)
@@ -70,7 +70,7 @@
Afctu3 <- function(u, xx, clip, cent, stand){
u^2*wfct(xx = xx, u = u, clip = clip, cent = cent, stand = stand)
}
- Afct <- function(x, clip, cent, stand, D1){
+ Afct.z <- function(x, clip, cent, stand, D1){
int1 <- E(D1, Afctu1, xx = x, clip = clip, cent = cent, stand = stand)
int2 <- E(D1, Afctu2, xx = x, clip = clip, cent = cent, stand = stand)
int3 <- E(D1, Afctu3, xx = x, clip = clip, cent = cent, stand = stand)
@@ -78,7 +78,7 @@
return((x %*% t(x))*int3 - (cent %*% t(x))*int2
- (x %*% t(cent))*int2 + (cent %*% t(cent))*int1)
}
- res <- E(Regressor, Afct, clip = clip, cent = cent, stand = stand,
+ res <- E(Regressor, Afct.z, clip = clip, cent = cent, stand = stand,
D1 = ErrorL2deriv)
}else{
Afct <- function(x, clip, stand, D1){
@@ -124,11 +124,11 @@
Afctu <- function(u, xx, clip, cent, stand){
(u - cent(xx))^2*wfct(xx = xx, u = u, clip = clip, cent = cent, stand = stand)
}
- Afct <- function(x, clip, cent, stand, D1){
+ Afct.z <- function(x, clip, cent, stand, D1){
return((x %*% t(x))*E(D1, Afctu, xx = x, clip = clip,
cent = cent, stand = stand))
}
- res <- E(Regressor, Afct, clip = clip, cent = cent, stand = stand,
+ res <- E(Regressor, Afct.z, clip = clip, cent = cent, stand = stand,
D1 = ErrorL2deriv)
}else{
Afct <- function(x, clip, stand, D1){
Modified: branches/robast-1.1/pkg/ROptRegTS/R/leastFavorableRadius.R
===================================================================
--- branches/robast-1.1/pkg/ROptRegTS/R/leastFavorableRadius.R 2018-07-17 12:26:22 UTC (rev 961)
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/robast -r 962
More information about the Robast-commits
mailing list