[Robast-commits] r648 - branches/robast-0.9/pkg/ROptReg/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Apr 16 22:15:51 CEST 2013
Author: ruckdeschel
Date: 2013-04-16 22:15:51 +0200 (Tue, 16 Apr 2013)
New Revision: 648
Added:
branches/robast-0.9/pkg/ROptReg/R/TotalVarIC.R
Modified:
branches/robast-0.9/pkg/ROptReg/R/AllClass.R
branches/robast-0.9/pkg/ROptReg/R/weights.R
Log:
ROptReg: committed changes from Schwenningen
Modified: branches/robast-0.9/pkg/ROptReg/R/AllClass.R
===================================================================
--- branches/robast-0.9/pkg/ROptReg/R/AllClass.R 2013-04-16 20:15:15 UTC (rev 647)
+++ branches/robast-0.9/pkg/ROptReg/R/AllClass.R 2013-04-16 20:15:51 UTC (rev 648)
@@ -174,7 +174,7 @@
return(TRUE)
})
-# conditional (error-free-variables) neighborhood
+# conditional (error-free-variables) neighborhood cf Ri94: 7.2.2
setClass("CondNeighborhood",
representation(radiusCurve = "function"),
contains = c("Neighborhood", "VIRTUAL"),
@@ -200,14 +200,14 @@
setClass("AvCondNeighborhood", representation(exponent = "numeric"),
contains = c("CondNeighborhood", "VIRTUAL"))
# average conditional neighborhood (exponent = 1)
-setClass("Av1CondNeighborhood",
+setClass("Av1CondNeighborhood", ### Ri:94 alpha=1 7.2.2 (9)
contains = c("AvCondNeighborhood", "VIRTUAL"),
validity = function(object){
if(object at exponent != 1)
stop("exponent has to be 1")
})
# average conditional convex contamination neighborhood (exponent = 1)
-setClass("Av1CondContNeighborhood",
+setClass("Av1CondContNeighborhood", ###### <- first priority
prototype = prototype(type = "average conditional convex contamination neighborhood",
radius = 0,
radiusCurve = function(x){1},
@@ -221,7 +221,7 @@
exponent = 1),
contains = c("Av1CondNeighborhood"))
# average square conditional neighborhood (exponent = 2)
-setClass("Av2CondNeighborhood",
+setClass("Av2CondNeighborhood", ### Ri:94 alpha=2 7.2.2 (9)
representation(Kinv="matrix",D="matrix"),
prototype(Kinv=matrix(1),D=matrix(1)),
contains = c("AvCondNeighborhood", "VIRTUAL"),
@@ -230,7 +230,7 @@
stop("exponent has to be 2")
})
# average square conditional convex contamination neighborhood (exponent = 2)
-setClass("Av2CondContNeighborhood",
+setClass("Av2CondContNeighborhood", ###### <- first priority
prototype = prototype(type = "average square conditional convex contamination neighborhood",
radius = 0,
radiusCurve = function(x){1},
@@ -288,6 +288,7 @@
return(TRUE)
})
+### weights are new w.r.t. ROptRegTS
setClass("CondBoundedWeight", representation(clip = "function"),
prototype(clip = function(x) Inf), contains = "RobWeight")
setClass("CondBdStWeight", representation(stand = "matrix"),
Added: branches/robast-0.9/pkg/ROptReg/R/TotalVarIC.R
===================================================================
--- branches/robast-0.9/pkg/ROptReg/R/TotalVarIC.R (rev 0)
+++ branches/robast-0.9/pkg/ROptReg/R/TotalVarIC.R 2013-04-16 20:15:51 UTC (rev 648)
@@ -0,0 +1,58 @@
+## generate IC
+## for internal use only!
+setMethod("generateIC", signature(neighbor = "TotalVarNeighborhood",
+ L2Fam = "L2RegTypeFamily"),
+ function(neighbor, L2Fam, res){
+ A <- res$A
+ a <- sign(as.vector(A))*res$a
+ b <- res$b
+ ICfct <- vector(mode = "list", length = 1)
+ Y <- as(A %*% L2Fam at L2deriv, "EuclRandVariable")
+ if(!is.null(res$d)){
+ a <- as.vector(A)*a
+ ICfct[[1]] <- function(x){ ind1 <- (Y(x) > 0); ind2 <- (Y(x) < 0)
+ (a+b)*ind1 + a*ind2 }
+ body(ICfct[[1]]) <- substitute({ ind1 <- (Y(x) > 0); ind2 <- (Y(x) < 0)
+ (a+b)*ind1 + a*ind2 },
+ list(Y = Y at Map[[1]], a = a, b = b))
+ }else{
+ if((a == -Inf) & (b == Inf)){
+ ICfct[[1]]<- function(x){ Y(x) }
+ body(ICfct[[1]]) <- substitute({ Y(x) }, list(Y = Y at Map[[1]]))
+ }else{
+ ICfct[[1]] <- function(x){ pmin(pmax(a, Y(x)), a+b) }
+ body(ICfct[[1]]) <- substitute({ pmin(pmax(a, Y(x)), a+b) },
+ list(Y = Y at Map[[1]], a = a, b = b))
+ }
+ }
+ if((a == -Inf) & (b == Inf))
+ clipUp <- Inf
+ else
+ clipUp <- a + b
+ return(TotalVarIC(
+ name = "IC of total variation type",
+ CallL2Fam = call("L2RegTypeFamily",
+ name = L2Fam at name,
+ 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,
+ 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)),
+ clipUp = clipUp,
+ clipLo = a,
+ stand = A,
+ neighborRadius = neighbor at radius,
+ Risks = res$risk,
+ Infos = matrix(res$info, ncol = 2,
+ dimnames = list(character(0), c("method", "message")))))
+ })
Modified: branches/robast-0.9/pkg/ROptReg/R/weights.R
===================================================================
--- branches/robast-0.9/pkg/ROptReg/R/weights.R 2013-04-16 20:15:15 UTC (rev 647)
+++ branches/robast-0.9/pkg/ROptReg/R/weights.R 2013-04-16 20:15:51 UTC (rev 648)
@@ -37,24 +37,35 @@
setMethod("getweight",
signature(Weight = "CondHampelWeight", neighbor = "ContNeighborhood",
biastype = "BiasType"),# normtype = "NormType"),
- function(Weight, neighbor, biastype, normW)
+ getMethod("getweight", signature=signature(Weight = "HampelWeight",
+ neighbor = "ContNeighborhood", biastype = "BiasType")))
+
+setMethod("getweight",
+ signature(Weight = "CondHampelWeight", neighbor = "TotalVarNeighborhood",
+ biastype = "BiasType"),
+ getMethod("getweight", signature=signature(Weight = "HampelWeight",
+ neighbor = "TotalVarNeighborhood", biastype = "BiasType")))
+
+setMethod("getweight",
+ signature(Weight = "CondHampelWeight", neighbor = "Av1CondContNeighborhood",
+ biastype = "BiasType"),# norm = "missing"),
+ function(Weight, neighbor, biastype, normW, ...)
{A <- stand(Weight)
b <- clip(Weight)
z <- cent(Weight)
function(x,X){
- y <- A%*%(x-z(X))
+ y <- as.numeric(as.matrix(A)%*%(x-z(X)))
norm0 <- fct(normW)(y)
- ind2 <- (norm0 < b(X)/2)
- norm1 <- ind2*b(X)/2 + (1-ind2)*norm0
- ind1 <- (norm0 < b(X))
- ind1 + (1-ind1)*b(X)/norm1
+ ind2 <- (norm0 < b/2)
+ norm1 <- ind2*b/2 + (1-ind2)*norm0
+ ind1 <- (norm0 < b)
+ ind1 + (1-ind1)*b/norm1
}
}
)
-
setMethod("getweight",
- signature(Weight = "CondHampelWeight", neighbor = "CondContNeighborhood",
+ signature(Weight = "CondHampelWeight", neighbor = "Av1CondContNeighborhood",
biastype = "onesidedBias"),# norm = "missing"),
function(Weight, neighbor, biastype, ...)
{A <- stand(Weight)
@@ -62,44 +73,44 @@
z <- cent(Weight)
function(x,X){
y <- as.numeric(as.matrix(A)%*%(x-z(X)))*sign(biastype)
- norm1 <- pmax(y,b(X)/2)
- pmin(1,b(X)/norm1)
+ norm1 <- pmax(y,b/2)
+ pmin(1,b/norm1)
}
}
)
setMethod("getweight",
- signature(Weight = "CondHampelWeight", neighbor = "CondContNeighborhood",
+ signature(Weight = "CondHampelWeight", neighbor = "Av1CondContNeighborhood",
biastype = "asymmetricBias"),# norm = "missing"),
function(Weight, neighbor, biastype, ...)
{A <- stand(Weight)
b <- clip(Weight)
- b1 <- function(X) b(X)/nu(biastype)[1]
- b2 <- function(X) b(X)/nu(biastype)[2]
+ b1 <- b/nu(biastype)[1]
+ b2 <- b/nu(biastype)[2]
z <- cent(Weight)
function(x,X){
y <- as.numeric(as.matrix(A)%*%(x-z(X)))
- norm1 <- pmax(-y,b1(X)/2)
- norm2 <- pmax(y,b2(X)/2)
- pmin(1,b1(X)/norm1,b2(X)/norm2)
+ norm1 <- pmax(-y,b1/2)
+ norm2 <- pmax(y,b2/2)
+ pmin(1,b1/norm1,b2/norm2)
}
}
)
setMethod("getweight",
- signature(Weight = "CondBdStWeight", neighbor = "CondTotalVarNeighborhood",
+ signature(Weight = "CondBdStWeight", neighbor = "Av1CondTotalVarNeighborhood",
biastype = "BiasType"),# norm = "missing"),
function(Weight, neighbor, biastype, ...)
{A <- stand(Weight)
b <- clip(Weight)
- b1 <- function(X) -b(X)[1]
- b2 <- function(X)b(X)[2]
+ b1 <- -b[1]
+ b2 <- b[2]
function(x,X){
y <- as.numeric(as.matrix(A)%*%x)
- norm1 <- pmax(-y,b1(X)/2)
- norm2 <- pmax(y,b2(X)/2)
- pmin(1,b1(X)/norm1,b2(X)/norm2)
+ norm1 <- pmax(-y,b1/2)
+ norm2 <- pmax(y,b2/2)
+ pmin(1,b1/norm1,b2/norm2)
}
}
)
@@ -178,10 +189,23 @@
}
)
+setMethod("minbiasweight",
+ signature(Weight = "CondHampelWeight", neighbor = "ContNeighborhood",
+ biastype = "BiasType"),
+getMethod("minbiasweight", signature=signature(Weight = "CondHampelWeight",
+ neighbor = "ContNeighborhood",
+ biastype = "BiasType")))
setMethod("minbiasweight",
- signature(Weight = "CondHampelWeight", neighbor = "ContNeighborhood",
- biastype = "BiasType"),# norm = "NormType"),
+ signature(Weight = "CondHampelWeight", neighbor = "TotalVarNeighborhood",
+ biastype = "BiasType"),
+getMethod("minbiasweight", signature=signature(Weight = "CondHampelWeight",
+ neighbor = "TotalVarNeighborhood",
+ biastype = "BiasType")))
+
+setMethod("minbiasweight",
+ signature(Weight = "CondHampelWeight", neighbor = "Av1CondContNeighborhood",
+ biastype = "BiasType"),# norm = "missing"),
function(Weight, neighbor, biastype, normW)
{A <- stand(Weight)
b <- clip(Weight)
@@ -197,7 +221,7 @@
setMethod("minbiasweight",
- signature(Weight = "CondHampelWeight", neighbor = "CondContNeighborhood",
+ signature(Weight = "CondHampelWeight", neighbor = "Av1CondContNeighborhood",
biastype = "asymmetricBias"),# norm = "missing"),
function(Weight, neighbor, biastype, ...)
{A <- stand(Weight)
@@ -216,7 +240,7 @@
)
setMethod("minbiasweight",
- signature(Weight = "CondHampelWeight", neighbor = "CondContNeighborhood",
+ signature(Weight = "CondHampelWeight", neighbor = "Av1CondContNeighborhood",
biastype = "onesidedBias"),# norm = "missing"),
function(Weight, neighbor, biastype, ...)
{A <- stand(Weight)
@@ -233,7 +257,7 @@
setMethod("minbiasweight",
- signature(Weight = "CondBdStWeight", neighbor = "CondTotalVarNeighborhood",
+ signature(Weight = "CondBdStWeight", neighbor = "Av1CondTotalVarNeighborhood",
biastype = "BiasType"),
function(Weight, neighbor, biastype, ...)
{A <- stand(Weight)
@@ -325,22 +349,3 @@
)
-setMethod("minbiasweight",
- signature(Weight = "HampelWeight", neighbor = "Av2CondContNeighborhood",
- biastype = "asymmetricBias"),# norm = "missing"),
- function(Weight, neighbor, biastype, normW, Kinv, D, ...)
- {A <- stand(Weight)
- fac <- .fac(normW,D,Kinv)
- b <- clip(Weight)*fac
- b1 <- function(X) -b(X)[1]
- b2 <- function(X) b(X)[2]
- z <- cent(Weight)
- function(x,X){
- y <- as.numeric(as.matrix(A)%*%(x-z(X)))
- indp <- (y>0)
- ind0 <- .eq(y)
- indm <- (y<0)
- indm*b1(X)/(y+ind0) + indp*b2(X)/(y+ind0)
- }
- }
- )
More information about the Robast-commits
mailing list