[Robast-commits] r731 - branches/robast-1.0/pkg/ROptEst/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sun Mar 23 17:50:05 CET 2014
Author: stamats
Date: 2014-03-23 17:50:05 +0100 (Sun, 23 Mar 2014)
New Revision: 731
Modified:
branches/robast-1.0/pkg/ROptEst/R/cniperCont.R
Log:
only minor editing
Modified: branches/robast-1.0/pkg/ROptEst/R/cniperCont.R
===================================================================
--- branches/robast-1.0/pkg/ROptEst/R/cniperCont.R 2014-03-23 15:06:29 UTC (rev 730)
+++ branches/robast-1.0/pkg/ROptEst/R/cniperCont.R 2014-03-23 16:50:05 UTC (rev 731)
@@ -65,7 +65,7 @@
}
-.getFunCnip <- function(IC1,IC2, risk, L2Fam, r, b20=NULL){
+.getFunCnip <- function(IC1, IC2, risk, L2Fam, r, b20=NULL){
riskfct <- getRiskFctBV(risk, biastype(risk))
@@ -75,17 +75,18 @@
if(length(R) > 1) R <- R$value
return(R)
}
- R1 <- .getTrVar (IC1)
- R2 <- .getTrVar (IC2)
+ R1 <- .getTrVar(IC1)
+ R2 <- .getTrVar(IC2)
fun <- function(x){
- y1 <- evalIC(IC1,as.matrix(x,ncol=1))
- r1 <- riskfct(var=R1,bias=r*fct(normtype(risk))(y1))
- if(!is.null(b20))
- r2 <- riskfct(var=R1,bias=b20) else{
- y2 <- sapply(x,function(x0) evalIC(IC2,x0))
- r2 <- riskfct(var=R2,bias=r*fct(normtype(risk))(y2))
+ y1 <- evalIC(IC1, as.matrix(x,ncol=1))
+ r1 <- riskfct(var=R1, bias=r*fct(normtype(risk))(y1))
+ if(!is.null(b20)){
+ r2 <- riskfct(var=R1, bias=b20)
+ }else{
+ y2 <- sapply(x, function(x0) evalIC(IC2,x0))
+ r2 <- riskfct(var=R2, bias=r*fct(normtype(risk))(y2))
}
r1 - r2
}
@@ -120,7 +121,7 @@
if(fCpl) b20 <- neighbor at radius*Risks(IC2)$asBias$value
dots$fromCniperPlot <- NULL
- fun <- .getFunCnip(IC1,IC2, risk, L2Fam, neighbor at radius, b20)
+ fun <- .getFunCnip(IC1, IC2, risk, L2Fam, neighbor at radius, b20)
if(missing(scaleX.fct)){
scaleX.fct <- p(L2Fam)
@@ -201,7 +202,7 @@
psi <- optIC(model = L2Fam, risk = asCov())
eta <- optIC(model = robMod, risk = risk)
- fun <- .getFunCnip(psi,eta, risk, L2Fam, neighbor at radius)
+ fun <- .getFunCnip(psi, eta, risk, L2Fam, neighbor at radius)
res <- uniroot(fun, lower = lower, upper = upper)$root
names(res) <- "cniper point"
More information about the Robast-commits
mailing list