[Robast-commits] r762 - in branches/robast-1.0/pkg: ROptEst/R RobAStBase/R RobAStBase/man

[noreply at r-forge.r-project.org]

Author: ruckdeschel
Date: 2014-07-24 17:32:09 +0200 (Thu, 24 Jul 2014)
New Revision: 762

Modified:
   branches/robast-1.0/pkg/ROptEst/R/cniperCont.R
   branches/robast-1.0/pkg/RobAStBase/R/getRiskBV.R
   branches/robast-1.0/pkg/RobAStBase/man/getRiskFctBV-methods.Rd
Log:
[RobAStBase/ROptEst] new methods for normtype and biastype for interpolRisk, as well as getRiskFctBV; now cniperPointPlot should work for GPD-type data 

Modified: branches/robast-1.0/pkg/ROptEst/R/cniperCont.R
===================================================================
--- branches/robast-1.0/pkg/ROptEst/R/cniperCont.R	2014-07-24 13:02:46 UTC (rev 761)
+++ branches/robast-1.0/pkg/ROptEst/R/cniperCont.R	2014-07-24 15:32:09 UTC (rev 762)
@@ -67,29 +67,35 @@
 
 .getFunCnip <- function(IC1,IC2, risk, L2Fam, r, b20=NULL){
 
-        riskfct <- getRiskFctBV(risk, biastype(risk))
+        bType <- biastype(risk)
+        nType <- normtype(risk)
+        fnorm <- fct(nType)
+        riskfct <- getRiskFctBV(risk, bType)
+
        .getTrVar <- function(IC){
            R <- Risks(IC)[["trAsCov"]]
            if(is.null(R)) R <- getRiskIC(IC, risk = trAsCov(), L2Fam = L2Fam)
+           if("trAsCov" %in% names(R)) R <- R[["trAsCov"]]
            if(length(R) > 1) R <- R$value
-           return(R)
+           return(c(R))
         }
         R1 <- .getTrVar (IC1)
         R2 <- .getTrVar (IC2)
 
-
         fun <- function(x){
             y1 <- sapply(x, function(x1)evalIC(IC1,as.matrix(x1,ncol=1)))
-            r1 <- riskfct(var=R1,bias=r*fct(normtype(risk))(y1))
+            b1 <- r*fnorm(y1)
+            r1 <- riskfct(var=R1,bias=b1)
             if(!is.null(b20)){
                r2 <- riskfct(var=R2, bias=b20)
             }else{
                y2 <- sapply(x,function(x0) evalIC(IC2,x0))
-               r2 <- riskfct(var=R2,bias=r*fct(normtype(risk))(y2))
+               b2 <- r*fnorm(y2)
+               r2 <- riskfct(var=R2,bias=b2)
             }
             r1 - r2
+            return(r1-r2)
         }
-
         return(fun)
 }
 
@@ -116,7 +122,7 @@
 
         b20 <- NULL
         fCpl <- eval(dots$fromCniperPlot)
-        if(!is.null(fCpl))
+        if(!is.null(fCpl)&&length(Risks(IC2)))
             if(fCpl) b20 <- neighbor at radius*Risks(IC2)$asBias$value
         dots$fromCniperPlot <- NULL
         
@@ -127,11 +133,13 @@
            scaleX.inv <- q(L2Fam)
         }
 
-        if(!is.null(as.list(mc)$lower)) lower <- p(L2Fam)(lower)
-        if(!is.null(as.list(mc)$upper)) upper <- p(L2Fam)(upper)
+        if("lower" %in% names(as.list(mc))) lower <- p(L2Fam)(lower)
+        if("upper" %in% names(as.list(mc))) upper <- p(L2Fam)(upper)
+
         x <-  q(L2Fam)(seq(lower,upper,length=n))
         if(is(distribution(L2Fam), "DiscreteDistribution"))
            x <- seq(q(L2Fam)(lower),q(L2Fam)(upper),length=n)
+
         resc <- .rescalefct(x, fun, scaleX, scaleX.fct,
                      scaleX.inv, scaleY, scaleY.fct, dots$xlim, dots$ylim, dots)
         dots$x <- resc$X

Modified: branches/robast-1.0/pkg/RobAStBase/R/getRiskBV.R
===================================================================
--- branches/robast-1.0/pkg/RobAStBase/R/getRiskBV.R	2014-07-24 13:02:46 UTC (rev 761)
+++ branches/robast-1.0/pkg/RobAStBase/R/getRiskBV.R	2014-07-24 15:32:09 UTC (rev 762)
@@ -1,3 +1,6 @@
+setMethod("getRiskFctBV", signature(risk = "interpolRisk", biastype = "ANY"),
+    function(risk) function(bias, var)  return(bias^2+var))
+
 setMethod("getRiskFctBV", signature(risk = "asGRisk", biastype = "ANY"),
     function(risk) function(bias, var)stop("not yet implemented"))
 
@@ -2,3 +5,3 @@
 setMethod("getRiskFctBV", signature(risk = "asMSE", biastype = "ANY"),
-    function(risk) function(bias, var) bias^2+var)
+    function(risk) function(bias, var)  return(bias^2+var))
 

Modified: branches/robast-1.0/pkg/RobAStBase/man/getRiskFctBV-methods.Rd
===================================================================
--- branches/robast-1.0/pkg/RobAStBase/man/getRiskFctBV-methods.Rd	2014-07-24 13:02:46 UTC (rev 761)
+++ branches/robast-1.0/pkg/RobAStBase/man/getRiskFctBV-methods.Rd	2014-07-24 15:32:09 UTC (rev 762)
@@ -2,6 +2,7 @@
 \docType{methods}
 \alias{getRiskFctBV}
 \alias{getRiskFctBV-methods}
+\alias{getRiskFctBV,interpolRisk,ANY-method}
 \alias{getRiskFctBV,asGRisk,ANY-method}
 \alias{getRiskFctBV,asMSE,ANY-method}
 \alias{getRiskFctBV,asSemivar,onesidedBias-method}
@@ -15,6 +16,10 @@
 
 \item{getRiskFctBV}{\code{signature(risk = "asGRisk", biastype = "ANY")}:
   returns an error that the respective method is not yet implemented. }
+\item{getRiskFctBV}{\code{signature(risk = "interpolRisk", biastype = "ANY")}:
+  returns a function with arguments \code{bias} and \code{variance}
+  to compute the asymptotic MSE for a given ALE at a situation where it has bias \code{bias}
+  (including the radius!) and variance \code{variance}. }
 \item{getRiskFctBV}{\code{signature(risk = "asMSE", biastype = "ANY")}:
   returns a function with arguments \code{bias} and \code{variance}
   to compute the asymptotic MSE for a given ALE at a situation where it has bias \code{bias}