[Robast-commits] r1052 - 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:19:48 CEST 2018
Author: ruckdeschel
Date: 2018-07-24 14:19:48 +0200 (Tue, 24 Jul 2018)
New Revision: 1052
Modified:
branches/robast-1.2/pkg/ROptRegTS/R/AllClass.R
branches/robast-1.2/pkg/ROptRegTS/R/Av1CondContIC.R
branches/robast-1.2/pkg/ROptRegTS/R/Av1CondTotalVarIC.R
branches/robast-1.2/pkg/ROptRegTS/R/Av2CondContIC.R
branches/robast-1.2/pkg/ROptRegTS/R/CondContIC.R
branches/robast-1.2/pkg/ROptRegTS/R/CondIC.R
branches/robast-1.2/pkg/ROptRegTS/R/CondTotalVarIC.R
branches/robast-1.2/pkg/ROptRegTS/R/getAsRiskRegTS.R
branches/robast-1.2/pkg/ROptRegTS/R/getFiRiskRegTS.R
branches/robast-1.2/pkg/ROptRegTS/R/getFixRobRegTypeIC_fiUnOvShoot.R
branches/robast-1.2/pkg/ROptRegTS/R/getInfCentRegTS.R
branches/robast-1.2/pkg/ROptRegTS/R/getInfClipRegTS.R
branches/robast-1.2/pkg/ROptRegTS/R/getInfGammaRegTS.R
branches/robast-1.2/pkg/ROptRegTS/R/getInfRobRegTypeIC_asBias.R
branches/robast-1.2/pkg/ROptRegTS/R/getInfRobRegTypeIC_asCov.R
branches/robast-1.2/pkg/ROptRegTS/R/getInfRobRegTypeIC_asGRisk_c1.R
branches/robast-1.2/pkg/ROptRegTS/R/getInfRobRegTypeIC_asGRisk_v1.R
branches/robast-1.2/pkg/ROptRegTS/R/getInfRobRegTypeIC_asUnOvShoot.R
branches/robast-1.2/pkg/ROptRegTS/R/getInfStandRegTS.R
pkg/ROptRegTS/R/AllClass.R
pkg/ROptRegTS/R/Av1CondContIC.R
pkg/ROptRegTS/R/Av1CondTotalVarIC.R
pkg/ROptRegTS/R/Av2CondContIC.R
pkg/ROptRegTS/R/CondContIC.R
pkg/ROptRegTS/R/CondIC.R
pkg/ROptRegTS/R/CondTotalVarIC.R
pkg/ROptRegTS/R/getAsRiskRegTS.R
pkg/ROptRegTS/R/getFiRiskRegTS.R
pkg/ROptRegTS/R/getFixRobRegTypeIC_fiUnOvShoot.R
pkg/ROptRegTS/R/getInfCentRegTS.R
pkg/ROptRegTS/R/getInfClipRegTS.R
pkg/ROptRegTS/R/getInfGammaRegTS.R
pkg/ROptRegTS/R/getInfRobRegTypeIC_asBias.R
pkg/ROptRegTS/R/getInfRobRegTypeIC_asCov.R
pkg/ROptRegTS/R/getInfRobRegTypeIC_asGRisk_c1.R
pkg/ROptRegTS/R/getInfRobRegTypeIC_asGRisk_v1.R
pkg/ROptRegTS/R/getInfRobRegTypeIC_asUnOvShoot.R
pkg/ROptRegTS/R/getInfStandRegTS.R
Log:
[ROptRegTS] fixed 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/AllClass.R
===================================================================
--- branches/robast-1.2/pkg/ROptRegTS/R/AllClass.R 2018-07-24 11:48:47 UTC (rev 1051)
+++ branches/robast-1.2/pkg/ROptRegTS/R/AllClass.R 2018-07-24 12:19:48 UTC (rev 1052)
@@ -160,8 +160,8 @@
radCurve <- object at neighbor@radiusCurve
if(is(D1, "UnivariateDistribution")){
if(is(D1, "AbscontDistribution")){
- xlo <- ifelse(is.finite(q(D1)(0)), q(D1)(0), q(D1)(distr::TruncQuantile))
- xup <- ifelse(is.finite(q(D1)(1)), q(D1)(1), q(D1)(1 - distr::TruncQuantile))
+ xlo <- ifelse(is.finite(q.l(D1)(0)), q.l(D1)(0), q.l(D1)(distr::TruncQuantile))
+ xup <- ifelse(is.finite(q.l(D1)(1)), q.l(D1)(1), q.l(D1)(1 - distr::TruncQuantile))
x <- seq(from = xlo, to = xup, by = 1e-3)
}else{
if(is(Regressor, "DiscreteDistribution"))
@@ -210,8 +210,8 @@
radCurve <- object at neighbor@radiusCurve
if(is(D1, "UnivariateDistribution")){
if(is(D1, "AbscontDistribution")){
- xlo <- ifelse(is.finite(q(D1)(0)), q(D1)(0), q(D1)(distr::TruncQuantile))
- xup <- ifelse(is.finite(q(D1)(1)), q(D1)(1), q(D1)(1 - distr::TruncQuantile))
+ xlo <- ifelse(is.finite(q.l(D1)(0)), q.l(D1)(0), q.l(D1)(distr::TruncQuantile))
+ xup <- ifelse(is.finite(q.l(D1)(1)), q.l(D1)(1), q.l(D1)(1 - distr::TruncQuantile))
x <- seq(from = xlo, to = xup, by = 1e-3)
}else{
if(is(Regressor, "DiscreteDistribution"))
Modified: branches/robast-1.2/pkg/ROptRegTS/R/Av1CondContIC.R
===================================================================
--- branches/robast-1.2/pkg/ROptRegTS/R/Av1CondContIC.R 2018-07-24 11:48:47 UTC (rev 1051)
+++ branches/robast-1.2/pkg/ROptRegTS/R/Av1CondContIC.R 2018-07-24 12:19:48 UTC (rev 1052)
@@ -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.2/pkg/ROptRegTS/R/Av1CondTotalVarIC.R
===================================================================
--- branches/robast-1.2/pkg/ROptRegTS/R/Av1CondTotalVarIC.R 2018-07-24 11:48:47 UTC (rev 1051)
+++ branches/robast-1.2/pkg/ROptRegTS/R/Av1CondTotalVarIC.R 2018-07-24 12:19:48 UTC (rev 1052)
@@ -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.2/pkg/ROptRegTS/R/Av2CondContIC.R
===================================================================
--- branches/robast-1.2/pkg/ROptRegTS/R/Av2CondContIC.R 2018-07-24 11:48:47 UTC (rev 1051)
+++ branches/robast-1.2/pkg/ROptRegTS/R/Av2CondContIC.R 2018-07-24 12:19:48 UTC (rev 1052)
@@ -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.2/pkg/ROptRegTS/R/CondContIC.R
===================================================================
--- branches/robast-1.2/pkg/ROptRegTS/R/CondContIC.R 2018-07-24 11:48:47 UTC (rev 1051)
+++ branches/robast-1.2/pkg/ROptRegTS/R/CondContIC.R 2018-07-24 12:19:48 UTC (rev 1052)
@@ -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.2/pkg/ROptRegTS/R/CondIC.R
===================================================================
--- branches/robast-1.2/pkg/ROptRegTS/R/CondIC.R 2018-07-24 11:48:47 UTC (rev 1051)
+++ branches/robast-1.2/pkg/ROptRegTS/R/CondIC.R 2018-07-24 12:19:48 UTC (rev 1052)
@@ -26,11 +26,12 @@
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{
if(is(K, "AbscontDistribution"))
- cond <- as.matrix(seq(from = q(K)(TruncQuantile), to = q(K)(1-TruncQuantile),
+ cond <- as.matrix(seq(from = q.l(K)(TruncQuantile), to = q.l(K)(1-TruncQuantile),
length = 100))
else
cond <- as.matrix(r(K)(1000))
@@ -74,11 +75,12 @@
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{
if(is(K, "AbscontDistribution"))
- cond <- as.matrix(seq(from = q(K)(TruncQuantile), to = q(K)(1-TruncQuantile),
+ cond <- as.matrix(seq(from = q.l(K)(TruncQuantile), to = q.l(K)(1-TruncQuantile),
length = 100))
else
cond <- as.matrix(r(K)(1000))
Modified: branches/robast-1.2/pkg/ROptRegTS/R/CondTotalVarIC.R
===================================================================
--- branches/robast-1.2/pkg/ROptRegTS/R/CondTotalVarIC.R 2018-07-24 11:48:47 UTC (rev 1051)
+++ branches/robast-1.2/pkg/ROptRegTS/R/CondTotalVarIC.R 2018-07-24 12:19:48 UTC (rev 1052)
@@ -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.2/pkg/ROptRegTS/R/getAsRiskRegTS.R
===================================================================
--- branches/robast-1.2/pkg/ROptRegTS/R/getAsRiskRegTS.R 2018-07-24 11:48:47 UTC (rev 1051)
+++ branches/robast-1.2/pkg/ROptRegTS/R/getAsRiskRegTS.R 2018-07-24 12:19:48 UTC (rev 1052)
@@ -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)
@@ -74,7 +75,7 @@
ErrorL2derivDistrSymm, trafo, maxiter, tol){
zi <- sign(as.vector(trafo))
A <- as.matrix(zi)
- z <- q(ErrorL2deriv)(0.5)
+ z <- q.l(ErrorL2deriv)(0.5)
Eu <- E(ErrorL2deriv, function(x, z){abs(x - z)}, z = z)
Ex <- E(Regressor, function(x){abs(x)})
b <- zi*as.vector(trafo)/(Ex*Eu)
@@ -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
@@ -163,7 +164,7 @@
erg <- optim(as.vector(trafo), bmin.fct, method = "Nelder-Mead",
control = list(reltol = tol, maxit = 100*maxiter),
Regressor = Regressor, trafo = trafo)
- z <- q(ErrorL2deriv)(0.5)
+ z <- q.l(ErrorL2deriv)(0.5)
b <- 1/(erg$value*E(ErrorL2deriv, function(x, z){abs(x - z)}, z = z))
return(list(asBias = b))
@@ -175,7 +176,7 @@
function(risk, ErrorL2deriv, Regressor, neighbor,
ErrorL2derivDistrSymm, trafo, maxiter, tol){
K <- E(Regressor, fun = function(x){ x %*% t(x) })
- z <- q(ErrorL2deriv)(0.5)
+ z <- q.l(ErrorL2deriv)(0.5)
Eu <- E(ErrorL2deriv, function(x, z){abs(x - z)}, z = z)
b <- sqrt(sum(diag(trafo %*% solve(K) %*% t(trafo))))/Eu
@@ -252,7 +253,7 @@
stop("not yet implemented")
- return(list(asBias = b))
+ return(list(asBias = NULL))
})
setMethod("getAsRiskRegTS", signature(risk = "asUnOvShoot",
ErrorL2deriv = "UnivariateDistribution",
@@ -281,8 +282,8 @@
neighbor = "CondNeighborhood"),
function(risk, ErrorL2deriv, Regressor, neighbor, clip, cent, stand){
if(is(Regressor, "AbscontDistribution")){
- xlower <- ifelse(is.finite(q(Regressor)(0)), q(Regressor)(0), q(Regressor)(distr::TruncQuantile))
- xupper <- ifelse(is.finite(q(Regressor)(1)), q(Regressor)(1), q(Regressor)(1 - distr::TruncQuantile))
+ xlower <- ifelse(is.finite(q.l(Regressor)(0)), q.l(Regressor)(0), q.l(Regressor)(distr::TruncQuantile))
+ xupper <- ifelse(is.finite(q.l(Regressor)(1)), q.l(Regressor)(1), q.l(Regressor)(1 - distr::TruncQuantile))
x.vec <- seq(from = xlower, to = xupper, by = 0.01)
}else{
if(is(Regressor, "DiscreteDistribution"))
Modified: branches/robast-1.2/pkg/ROptRegTS/R/getFiRiskRegTS.R
===================================================================
--- branches/robast-1.2/pkg/ROptRegTS/R/getFiRiskRegTS.R 2018-07-24 11:48:47 UTC (rev 1051)
+++ branches/robast-1.2/pkg/ROptRegTS/R/getFiRiskRegTS.R 2018-07-24 12:19:48 UTC (rev 1052)
@@ -292,8 +292,8 @@
m <- distr::DefaultNrFFTGridPointsExponent
if(is(Regressor, "AbscontDistribution")){
- xlower <- ifelse(is.finite(q(Regressor)(0)), q(Regressor)(0), q(Regressor)(distr::TruncQuantile))
- xupper <- ifelse(is.finite(q(Regressor)(1)), q(Regressor)(1), q(Regressor)(1 - distr::TruncQuantile))
+ xlower <- ifelse(is.finite(q.l(Regressor)(0)), q.l(Regressor)(0), q.l(Regressor)(distr::TruncQuantile))
+ xupper <- ifelse(is.finite(q.l(Regressor)(1)), q.l(Regressor)(1), q.l(Regressor)(1 - distr::TruncQuantile))
x.vec <- seq(from = xlower, to = xupper, length = 1000)
}else{
if(is(Regressor, "DiscreteDistribution"))
@@ -366,8 +366,8 @@
m <- distr::DefaultNrFFTGridPointsExponent
if(is(Regressor, "AbscontDistribution")){
- xlower <- ifelse(is.finite(q(Regressor)(0)), q(Regressor)(0), q(Regressor)(distr::TruncQuantile))
- xupper <- ifelse(is.finite(q(Regressor)(1)), q(Regressor)(1), q(Regressor)(1 - distr::TruncQuantile))
+ xlower <- ifelse(is.finite(q.l(Regressor)(0)), q.l(Regressor)(0), q.l(Regressor)(distr::TruncQuantile))
+ xupper <- ifelse(is.finite(q.l(Regressor)(1)), q.l(Regressor)(1), q.l(Regressor)(1 - distr::TruncQuantile))
x.vec <- seq(from = xlower, to = xupper, length = 1000)
}else{
if(is(Regressor, "DiscreteDistribution"))
Modified: branches/robast-1.2/pkg/ROptRegTS/R/getFixRobRegTypeIC_fiUnOvShoot.R
===================================================================
--- branches/robast-1.2/pkg/ROptRegTS/R/getFixRobRegTypeIC_fiUnOvShoot.R 2018-07-24 11:48:47 UTC (rev 1051)
+++ branches/robast-1.2/pkg/ROptRegTS/R/getFixRobRegTypeIC_fiUnOvShoot.R 2018-07-24 12:19:48 UTC (rev 1052)
@@ -53,8 +53,8 @@
tol, warn, Algo, cont){
radiusCurve <- neighbor at radiusCurve
if(is(Regressor, "AbscontDistribution")){
- xlower <- ifelse(is.finite(q(Regressor)(0)), q(Regressor)(0), q(Regressor)(distr::TruncQuantile))
- xupper <- ifelse(is.finite(q(Regressor)(1)), q(Regressor)(1), q(Regressor)(1 - distr::TruncQuantile))
+ xlower <- ifelse(is.finite(q.l(Regressor)(0)), q.l(Regressor)(0), q.l(Regressor)(distr::TruncQuantile))
+ xupper <- ifelse(is.finite(q.l(Regressor)(1)), q.l(Regressor)(1), q.l(Regressor)(1 - distr::TruncQuantile))
x.vec <- seq(from = xlower, to = xupper, length = 1000)
}else{
if(is(Regressor, "DiscreteDistribution"))
@@ -100,11 +100,11 @@
return(NA)
}
}else{
- if(is.finite(q(Regressor)(0)))
+ if(is.finite(q.l(Regressor)(0)))
yleft <- NA
else
yleft <- b[1]
- if(is.finite(q(Regressor)(1)))
+ if(is.finite(q.l(Regressor)(1)))
yright <- NA
else
yright <- b.vec[length(b.vec)]
Modified: branches/robast-1.2/pkg/ROptRegTS/R/getInfCentRegTS.R
===================================================================
--- branches/robast-1.2/pkg/ROptRegTS/R/getInfCentRegTS.R 2018-07-24 11:48:47 UTC (rev 1051)
+++ branches/robast-1.2/pkg/ROptRegTS/R/getInfCentRegTS.R 2018-07-24 12:19:48 UTC (rev 1052)
@@ -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){
@@ -39,11 +40,11 @@
}
return(E(K, gu.fct, z = z, c0 = c0, D1 = D1))
}
- lower <- q(ErrorL2deriv)(distr::TruncQuantile)
- upper <- q(ErrorL2deriv)(1-distr::TruncQuantile)
+ 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))
@@ -94,11 +100,11 @@
z*(1-p(D1)(z/x)) + x*(m1df(D1, z/x) - m1df(D1, b/x)) + b*p(D1)(b/x)
}
}
- lower <- q(ErrorL2deriv)(distr::TruncQuantile)
- upper <- q(ErrorL2deriv)(1-distr::TruncQuantile)
+ 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",
@@ -130,11 +136,11 @@
return(NA)
}
}else{
- if(is.finite(q(Regressor)(0)))
+ if(is.finite(q.l(Regressor)(0)))
yleft <- NA
else
yleft <- z.vec[1]
- if(is.finite(q(Regressor)(1)))
+ if(is.finite(q.l(Regressor)(1)))
yright <- NA
else
yright <- z.vec[length(z.vec)]
@@ -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])
@@ -203,8 +209,8 @@
z.fct <- function(z, c0, D1){
return(c0 + (z-c0)*p(D1)(z-c0) - (z+c0)*p(D1)(z+c0) + m1df(D1, z+c0) - m1df(D1, z-c0))
}
- lower <- q(ErrorL2deriv)(distr::TruncQuantile)
- upper <- q(ErrorL2deriv)(1-distr::TruncQuantile)
+ lower <- q.l(ErrorL2deriv)(distr::TruncQuantile)
+ upper <- q.l(ErrorL2deriv)(1-distr::TruncQuantile)
return(uniroot(z.fct, lower = lower, upper = upper, tol = tol.z,
c0=clip, D1=ErrorL2deriv)$root)
@@ -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))
@@ -228,8 +234,8 @@
zfun <- function(x, z0, c0, D1, tol.z){
if(x == 0) return(0)
- lower <- q(D1)(distr::TruncQuantile)
- upper <- q(D1)(1-distr::TruncQuantile)
+ lower <- q.l(D1)(distr::TruncQuantile)
+ upper <- q.l(D1)(1-distr::TruncQuantile)
return(uniroot(g.fct, lower = lower, upper = upper, tol = tol.z,
c0 = c0, xx = x, D1 = D1)$root)
@@ -245,11 +251,11 @@
return(NA)
}
}else{
- if(is.finite(q(Regressor)(0)))
+ if(is.finite(q.l(Regressor)(0)))
yleft <- NA
else
yleft <- z.vec[1]
- if(is.finite(q(Regressor)(1)))
+ if(is.finite(q.l(Regressor)(1)))
yright <- NA
else
yright <- z.vec[length(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))
@@ -278,8 +284,8 @@
zfun <- function(x, z0, c0, A0, D1, tol.z){
if(all(x == numeric(length(x)))) return(0)
- lower <- q(D1)(distr::TruncQuantile)
- upper <- q(D1)(1-distr::TruncQuantile)
+ lower <- q.l(D1)(distr::TruncQuantile)
+ upper <- q.l(D1)(1-distr::TruncQuantile)
return(uniroot(g.fct, lower = lower, upper = upper, tol = tol.z,
c0 = c0, A0 = A0, xx = x, D1 = D1)$root)
Modified: branches/robast-1.2/pkg/ROptRegTS/R/getInfClipRegTS.R
===================================================================
--- branches/robast-1.2/pkg/ROptRegTS/R/getInfClipRegTS.R 2018-07-24 11:48:47 UTC (rev 1051)
+++ branches/robast-1.2/pkg/ROptRegTS/R/getInfClipRegTS.R 2018-07-24 12:19:48 UTC (rev 1052)
@@ -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.2/pkg/ROptRegTS/R/getInfGammaRegTS.R
===================================================================
--- branches/robast-1.2/pkg/ROptRegTS/R/getInfGammaRegTS.R 2018-07-24 11:48:47 UTC (rev 1051)
+++ branches/robast-1.2/pkg/ROptRegTS/R/getInfGammaRegTS.R 2018-07-24 12:19:48 UTC (rev 1052)
@@ -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)
}
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/robast -r 1052
More information about the Robast-commits
mailing list