From noreply at r-forge.r-project.org  Sun Feb 23 00:36:17 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Sun, 23 Feb 2014 00:36:17 +0100 (CET)
Subject: [Robast-commits] r721 - in branches/robast-1.0/pkg: ROptEst/R
	RobAStBase RobAStBase/R
Message-ID: <20140222233617.36418186BEA@r-forge.r-project.org>

Author: ruckdeschel
Date: 2014-02-23 00:36:16 +0100 (Sun, 23 Feb 2014)
New Revision: 721

Modified:
   branches/robast-1.0/pkg/ROptEst/R/AllPlot.R
   branches/robast-1.0/pkg/ROptEst/R/comparePlot.R
   branches/robast-1.0/pkg/ROptEst/R/getReq.R
   branches/robast-1.0/pkg/RobAStBase/R/comparePlot.R
   branches/robast-1.0/pkg/RobAStBase/R/cutoff-class.R
   branches/robast-1.0/pkg/RobAStBase/R/ddPlot_utils.R
   branches/robast-1.0/pkg/RobAStBase/R/infoPlot.R
   branches/robast-1.0/pkg/RobAStBase/R/outlyingPlot.R
   branches/robast-1.0/pkg/RobAStBase/RobAStBase-Ex.R
Log:
fixed errors detected by Matthias / Misha

Modified: branches/robast-1.0/pkg/ROptEst/R/AllPlot.R
===================================================================
--- branches/robast-1.0/pkg/ROptEst/R/AllPlot.R	2014-01-02 12:49:35 UTC (rev 720)
+++ branches/robast-1.0/pkg/ROptEst/R/AllPlot.R	2014-02-22 23:36:16 UTC (rev 721)
@@ -47,6 +47,6 @@
 
 .getExtremeCoordIC <- function(IC, D, indi, n = 10000){
     x <- q(D)(seq(1/2/n,1-1/2/n, length=n))
-    y <- (matrix(evalIC(IC,matrix(x,ncol=1)),ncol=n))[indi,]
+    y <- (matrix(evalIC(IC,matrix(x,ncol=1)),ncol=n))[indi,,drop=FALSE]
     return(cbind(min=apply(y,1,min),max=apply(y,1,max)))
 }
\ No newline at end of file

Modified: branches/robast-1.0/pkg/ROptEst/R/comparePlot.R
===================================================================
--- branches/robast-1.0/pkg/ROptEst/R/comparePlot.R	2014-01-02 12:49:35 UTC (rev 720)
+++ branches/robast-1.0/pkg/ROptEst/R/comparePlot.R	2014-02-22 23:36:16 UTC (rev 721)
@@ -1,3 +1,4 @@
+.oldcomparePlot <- getMethod("comparePlot", signature("IC","IC"))
 setMethod("comparePlot", signature("IC","IC"),
     function(obj1,obj2, obj3 = NULL, obj4 = NULL, data = NULL,
              ..., withSweave = getdistrOption("withSweave"),
@@ -45,8 +46,7 @@
         }
         mcl$MBRB <- MBRB
         mcl$withMBR <- withMBR
-        do.call(getMethod("comparePlot", signature("IC","IC"),
-                           where="RobAStBase"), as.list(mcl[-1]),
+        do.call(.oldcomparePlot, as.list(mcl[-1]),
                 envir=parent.frame(2))
         return(invisible())
       })

Modified: branches/robast-1.0/pkg/ROptEst/R/getReq.R
===================================================================
--- branches/robast-1.0/pkg/ROptEst/R/getReq.R	2014-01-02 12:49:35 UTC (rev 720)
+++ branches/robast-1.0/pkg/ROptEst/R/getReq.R	2014-02-22 23:36:16 UTC (rev 721)
@@ -2,8 +2,10 @@
    list(s = getRiskIC(IC,risk=trAsCov())$trAsCov$value^.5,
         b = getRiskIC(IC,risk=asBias(),neighbor=neighbor)$asBias$value)
 
-getReq <- function(Risk,neighbor,IC1,IC2,n=1,upper=15){
-            if(!is(IC1,"IC")||!is(IC2,"IC")) 
+getReq <- function(Risk,neighbor,IC1,IC2,n=1,upper=15,
+                   radOrOutl=c("radius","Outlier")){
+            radOrOutl <- match.arg(radOrOutl)
+            if(!is(IC1,"IC")||!is(IC2,"IC"))
                stop("Arguments IC1, IC2 must be of class 'IC'.")
             if(!identical(IC1 at CallL2Fam,IC2 at CallL2Fam))
                stop("Arguments IC1, IC2 must be of defined for the same model.")
@@ -24,6 +26,8 @@
                  get.asGRisk.fct(Risk)(r,s=sb2$s,b=sb2$b)
             }
             r0 <- uniroot(dRisk,lower=0, upper=upper)$root/n^.5
+            if(radOrOutl=="Outlier")
+               r0 <- if(sb1$s<=sb2$s) floor(r0*n) else ceiling(r0*n)
             if(sb1$s<=sb2$s)
                return(c(0,r0))
             else   

Modified: branches/robast-1.0/pkg/RobAStBase/R/comparePlot.R
===================================================================
--- branches/robast-1.0/pkg/RobAStBase/R/comparePlot.R	2014-01-02 12:49:35 UTC (rev 720)
+++ branches/robast-1.0/pkg/RobAStBase/R/comparePlot.R	2014-02-22 23:36:16 UTC (rev 721)
@@ -24,7 +24,6 @@
         xc <- c(.xc("obj1"), .xc("obj2"))
         if(!is.null(obj3)) xc <- c(xc, .xc("obj3"))
         if(!is.null(obj4)) xc <- c(xc, .xc("obj4"))
-
         dots <- match.call(call = sys.call(sys.parent(1)),
                        expand.dots = FALSE)$"..."
         dotsP <- dots

Modified: branches/robast-1.0/pkg/RobAStBase/R/cutoff-class.R
===================================================================
--- branches/robast-1.0/pkg/RobAStBase/R/cutoff-class.R	2014-01-02 12:49:35 UTC (rev 720)
+++ branches/robast-1.0/pkg/RobAStBase/R/cutoff-class.R	2014-02-22 23:36:16 UTC (rev 721)
@@ -46,7 +46,7 @@
                    cutoff.quantile  = 0.95)}
 
 cutoff.chisq <- function(){cutoff(name = "chisq",
-                   body.fct0 = substitute({dim = nrow(data)
-                                  qchisq(df=dim,cutoff.quantile)^.5
+                   body.fct0 = substitute({dim = nrow(as.matrix(data))
+                                  qchisq(df = dim, cutoff.quantile)^.5
                                   }),
                    cutoff.quantile  = 0.95)}

Modified: branches/robast-1.0/pkg/RobAStBase/R/ddPlot_utils.R
===================================================================
--- branches/robast-1.0/pkg/RobAStBase/R/ddPlot_utils.R	2014-01-02 12:49:35 UTC (rev 720)
+++ branches/robast-1.0/pkg/RobAStBase/R/ddPlot_utils.R	2014-02-22 23:36:16 UTC (rev 721)
@@ -107,6 +107,7 @@
       if(is.null(dots$lwd)) dots$lwd <- par("lwd")
       if(is.null(dots$lty)) dots$lty <- par("lty")
 
+      if(is.null(col.cutoff)) col.cutoff <- "red"
       col.cutoff <- rep(col.cutoff,length.out=2)
       if(missing(lty.cutoff) && !is.null(dots$lty)) lty.cutoff <- dots$lty
       if(missing(lwd.cutoff) && !is.null(dots$lwd)) lwd.cutoff <- dots$lwd

Modified: branches/robast-1.0/pkg/RobAStBase/R/infoPlot.R
===================================================================
--- branches/robast-1.0/pkg/RobAStBase/R/infoPlot.R	2014-01-02 12:49:35 UTC (rev 720)
+++ branches/robast-1.0/pkg/RobAStBase/R/infoPlot.R	2014-02-22 23:36:16 UTC (rev 721)
@@ -315,6 +315,7 @@
                if(missing(col.pts)) col.pts <- c(col, colI)
                col.pts <- rep(col.pts, length.out=2)
                pch.pts <- matrix(rep(pch.pts, length.out=2*n),n,2)
+               cex.pts <- rep(cex.pts,length.out=2)
                jitter.fac <- rep(jitter.fac, length.out=2)
                with.lab <- rep(with.lab, length.out=2)
                lab.font <- rep(lab.font, length.out=2)
@@ -349,27 +350,31 @@
 
 
                pL.abs <- substitute({
+                   ICy0r1 <- ICy0r
+                   ICy0cr1 <- ICy0cr
                    if(is(distr, "DiscreteDistribution")){
-                      ICy0 <- jitter(ICy0, factor = jitter.fac0[1])
-                      ICy0c <- jitter(ICy0c, factor = jitter.fac0[2])
+                      ICy0r1 <- jitter(ICy0r1, factor = jitter.fac0[1])
+                      ICy0cr1 <- jitter(ICy0cr1, factor = jitter.fac0[2])
                    }
+
                    f1 <- log(ICy0+1)*3*cex0[1]
                    f1c <- log(ICy0c+1)*3*cex0[2]
 
                    col.pts <- if(!is.na(al0)) sapply(col0,
                               addAlphTrsp2col, alpha=al0) else col0
 
-                   do.pts(y0, ICy0r, f1,col.pts[1],pch0[,1])
-                   do.pts(y0c, ICy0cr, f1c,col.pts[2],pch0[,2])
+                   do.pts(y0, ICy0r1, f1,col.pts[1],pch0[,1])
+                   do.pts(y0c, ICy0cr1, f1c,col.pts[2],pch0[,2])
                    if(with.lab0){
-                      tx(y0, ICy0r, lab.pts0, f1/2, col0[1])
-                      tx(y0c, ICy0cr, lab.pts0C, f1c/2, col0[2])
+                      tx(y0, ICy0r1, lab.pts0, f1/2, col0[1])
+                      tx(y0c, ICy0cr1, lab.pts0C, f1c/2, col0[2])
                    }
                    pL0
                    }, list(ICy0c = y.dC, ICy0 = y.d,
                            ICy0r = y.dr, ICy0cr = y.dCr,
                            pL0 = pL, y0 = x.dr, y0c = x.dCr,
-                           cex0 = cex.pts, pch0 = pch.pts, al0 = alp.v[1],
+                           cex0 = cex.pts,
+                           pch0 = pch.pts, al0 = alp.v[1],
                            col0 = col.pts, with.lab0 = with.lab, n0 = n,
                            lab.pts0 = lab.pts[i.d], lab.pts0C = lab.pts[i.dC],
                            jitter.fac0 = jitter.fac)

Modified: branches/robast-1.0/pkg/RobAStBase/R/outlyingPlot.R
===================================================================
--- branches/robast-1.0/pkg/RobAStBase/R/outlyingPlot.R	2014-01-02 12:49:35 UTC (rev 720)
+++ branches/robast-1.0/pkg/RobAStBase/R/outlyingPlot.R	2014-02-22 23:36:16 UTC (rev 721)
@@ -36,41 +36,58 @@
   
      if(missing(dist.y)){
        if(robCov.y){
-          evIC = evalIC(IC.y,as.matrix(data))
-          asVar = solve(getCov(CovMcd(data.frame(evIC[1,],evIC[2,]),alpha=0.5)))
-          cat("\n", sep="", gettext("Robust asVar"), ":\n")
-          print(asVar)
-           }else{
-          if("asCov" %in% names(Risks(IC.y)))
-             if(is.matrix(Risks(IC.y)$asCov) || length(Risks(IC.y)$asCov) == 1)
-                {asVar <- Risks(IC.y)$asCov
-                  cat("\n", sep="", gettext("asVar"));# print("HHHH");
-                  print(asVar)
-                 }
-              else{asVar <- Risks(IC.y)$asCov$value 
-                   cat("\n", sep="", gettext("asVar"));#print("HHHH");
+          evIC <- evalIC(IC.y,as.matrix(data))
+          if(is.null(dim(evIC))){
+             asVar <- PosSemDefSymmMatrix(mad(evIC)^2)
+             if(asVar < 1e-8) asVar <- 1
+          }else{
+            dimevIC <- dim(evIC)[1]
+            devIC <- data.frame(t(evIC[1:dimevIC,,drop=FALSE]))
+            CMcd <- PosSemDefSymmMatrix(getCov(CovMcd(devIC,alpha=0.5)))
+            asVar <- solve(CMcd)
+ #           cat("\n", sep="", gettext("Robust asVar"), ":\n")
+ #           print(asVar)
+          }
+       }else{
+            if("asCov" %in% names(Risks(IC.y)))
+               if(is.matrix(Risks(IC.y)$asCov) || length(Risks(IC.y)$asCov) == 1)
+                  {asVar <- Risks(IC.y)$asCov
+                    cat("\n", sep="", gettext("asVar"));# print("HHHH");
+                    print(asVar)
+                   }
+                else{asVar <- Risks(IC.y)$asCov$value
+                     cat("\n", sep="", gettext("asVar"));#print("HHHH");
+                     print(asVar)
+                   }
+                else{asVar <- getRiskIC(IC.y, risk = asCov())$asCov$value
+                     cat("\n", sep="", gettext("Classic asVar"));
+                    #  print("HHHH");
                    print(asVar)
-                 }
-              else{asVar <- getRiskIC(IC.y, risk = asCov())$asCov$value
-                   cat("\n", sep="", gettext("Classic asVar"));
-                 #  print("HHHH");
-                 print(asVar)
-                 }}
+                   }
+       }
      
-        asVar <- PosSemDefSymmMatrix(solve(asVar))
-        mc$dist.y <- QFNorm(name = gettext("Mahalonobis-Norm"), QuadForm = asVar)
+          asVar <- PosSemDefSymmMatrix(solve(asVar))
+          mc$dist.y <- QFNorm(name = gettext("Mahalonobis-Norm"), QuadForm = asVar)
      }
 
   if(missing(dist.x)){
         #mc$dist.x <- NormType()
     if(robCov.x){
       evIC = evalIC(IC.x,as.matrix(data))
-      asVar = getCov(CovMcd(data.frame(evIC[1,],evIC[2,]),alpha=0.5))
+      if(is.null(dim(evIC))){
+         asVar <- PosSemDefSymmMatrix(mad(evIC)^2)
+         if(asVar < 1e-8) asVar <- 1
+      }else{
+         dimevIC <- dim(evIC)[1]
+         devIC <- data.frame(t(evIC[1:dimevIC,,drop=FALSE]))
+         CMcd <- PosSemDefSymmMatrix(getCov(CovMcd(devIC,alpha=0.5)))
+         asVar <- solve(CMcd)
+#         cat("\n", sep="", gettext("Robust asVar"), ":\n")
+#         print(asVar)
+      }
       #cat("\nRobust asVar:") ;print("KKKKK")
       #print(asVar)
-      }
-     else{
-   if("asCov" %in% names(Risks(IC.y)))
+   }else{if("asCov" %in% names(Risks(IC.y)))
       if(is.matrix(Risks(IC.x)$asCov) || length(Risks(IC.y)$asCov) == 1)
                {asVar <- Risks(IC.x)$asCov
                   cat("\n", sep="", gettext("asVar"));

Modified: branches/robast-1.0/pkg/RobAStBase/RobAStBase-Ex.R
===================================================================
--- branches/robast-1.0/pkg/RobAStBase/RobAStBase-Ex.R	2014-01-02 12:49:35 UTC (rev 720)
+++ branches/robast-1.0/pkg/RobAStBase/RobAStBase-Ex.R	2014-02-22 23:36:16 UTC (rev 721)
@@ -4,7 +4,7 @@
 options(pager = "console")
 library('RobAStBase')
 
-assign(".oldSearch", search(), pos = 'CheckExEnv')
+base::assign(".oldSearch", base::search(), pos = 'CheckExEnv')
 cleanEx()
 nameEx("0RobAStBase-package")
 ### * 0RobAStBase-package
@@ -92,6 +92,29 @@
 
 
 cleanEx()
+nameEx("ComparePlotWrapper")
+### * ComparePlotWrapper
+
+flush(stderr()); flush(stdout())
+
+### Name: ComparePlot
+### Title: Wrapper function for function comparePlot
+### Aliases: ComparePlot
+
+### ** Examples
+
+# Gamma
+fam <- GammaFamily()
+rfam <- InfRobModel(fam, ContNeighborhood(0.5))
+IC1 <- optIC(model = fam, risk = asCov())
+IC2 <- makeIC(list(function(x)sin(x),function(x)x^2), L2Fam = fam)
+Y <- distribution(fam)
+y <- r(Y)(100)
+ComparePlot(IC1, IC2, y, withCall = TRUE)
+
+
+
+cleanEx()
 nameEx("ContIC-class")
 ### * ContIC-class
 
@@ -386,6 +409,27 @@
 
 
 cleanEx()
+nameEx("InfoPlotWrapper")
+### * InfoPlotWrapper
+
+flush(stderr()); flush(stdout())
+
+### Name: InfoPlot
+### Title: Wrapper function for information plot method
+### Aliases: InfoPlot
+
+### ** Examples
+
+# Gamma
+fam  <-  GammaFamily()
+IC <- optIC(model = fam, risk = asCov())
+Y <- distribution(fam)
+data  <-  r(Y)(1000)
+InfoPlot(IC, data, withCall = FALSE)
+
+
+
+cleanEx()
 nameEx("MEstimate-class")
 ### * MEstimate-class
 
@@ -405,6 +449,28 @@
 
 
 cleanEx()
+nameEx("PlotICWrapper")
+### * PlotICWrapper
+
+flush(stderr()); flush(stdout())
+
+### Name: PlotIC
+### Title: Wrapper function for plot method for IC
+### Aliases: PlotIC
+
+### ** Examples
+
+# Gamma
+fam <- GammaFamily()
+rfam <- InfRobModel(fam, ContNeighborhood(0.5))
+IC <- optIC(model = fam, risk = asCov())
+Y <- distribution(fam)
+y <- r(Y)(1000)
+PlotIC(IC, y, withCall = FALSE)
+
+
+
+cleanEx()
 nameEx("RobAStBaseMASK")
 ### * RobAStBaseMASK
 
@@ -767,6 +833,19 @@
 ##D infoPlot(IC1, data=data[1:10], mfColRow = FALSE, panel.first= grid(),
 ##D          with.lab = TRUE, cex.pts=0.7)
 ##D par(mfrow=c(1,1))
+##D 
+##D ICr <- makeIC(list(function(x)sign(x),function(x)sign(abs(x)-qnorm(.75))),N)
+##D data <- r(N)(600)
+##D data.c <- c(data, 1000*data[1:30])
+##D par(mfrow=c(3,1))
+##D infoPlot(ICr, data=data.c, tmar=c(4.1,0,0), bmar=c(0,0,4.1),
+##D          xaxt=c("n","n","s"), mfColRow = FALSE, panel.first= grid(),
+##D          cex.pts=c(.9,.9), alpha.trsp=20, lwd=2, lwdI=1.5, col=3,
+##D          col.pts=c(3,2), colI=2, pch.pts=c(20,20), inner=FALSE,
+##D          scaleX = TRUE, scaleX.fct=pnorm, scaleX.inv=qnorm,
+##D          scaleY=TRUE, scaleY.fct=function(x) pchisq(x,df=1),
+##D          scaleY.inv=function(x)qchisq(x,df=1),legend.cex = 1.0)
+##D 
 ## End(Not run)
 
 
@@ -1092,7 +1171,8 @@
 
 ### * <FOOTER>
 ###
-cat("Time elapsed: ", proc.time() - get("ptime", pos = 'CheckExEnv'),"\n")
+options(digits = 7L)
+base::cat("Time elapsed: ", proc.time() - base::get("ptime", pos = 'CheckExEnv'),"\n")
 grDevices::dev.off()
 ###
 ### Local variables: ***


From noreply at r-forge.r-project.org  Mon Feb 24 18:58:40 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Mon, 24 Feb 2014 18:58:40 +0100 (CET)
Subject: [Robast-commits] r722 - in branches/robast-1.0/pkg: RobAStBase/R
	RobExtremes/R
Message-ID: <20140224175841.0F6FE186A88@r-forge.r-project.org>

Author: ruckdeschel
Date: 2014-02-24 18:58:37 +0100 (Mon, 24 Feb 2014)
New Revision: 722

Modified:
   branches/robast-1.0/pkg/RobAStBase/R/ddPlot_utils.R
   branches/robast-1.0/pkg/RobAStBase/R/kStepEstimator.R
   branches/robast-1.0/pkg/RobExtremes/R/getStartIC.R
Log:
RobAStBase: introduce jitter for points in ddPlot for DiscreteDistributions
RobAStBase/RobExtremes: fixed issue with updateStep in kStepEstimator when using interpol risks (somehow modifyIC had not been attached in prior steps...)

Modified: branches/robast-1.0/pkg/RobAStBase/R/ddPlot_utils.R
===================================================================
--- branches/robast-1.0/pkg/RobAStBase/R/ddPlot_utils.R	2014-02-22 23:36:16 UTC (rev 721)
+++ branches/robast-1.0/pkg/RobAStBase/R/ddPlot_utils.R	2014-02-24 17:58:37 UTC (rev 722)
@@ -231,6 +231,12 @@
       id0.xy <- id.n1[id.xy]
       id0.x <- id.n1[id.x]
       id0.y <- id.n1[id.y]
+
+      if(any(duplicated(ndata.x)&duplicated(ndata.y))){
+          ndata.x <- jitter(ndata.x, factor=jitt.fac)
+          ndata.y <- jitter(ndata.y, factor=jitt.fac)
+      }
+
       do.call(plot, args = c(list(x = ndata.x, y=ndata.y, type = "p"), pdots))
       do.call(box,args=c(adots))
 

Modified: branches/robast-1.0/pkg/RobAStBase/R/kStepEstimator.R
===================================================================
--- branches/robast-1.0/pkg/RobAStBase/R/kStepEstimator.R	2014-02-22 23:36:16 UTC (rev 721)
+++ branches/robast-1.0/pkg/RobAStBase/R/kStepEstimator.R	2014-02-24 17:58:37 UTC (rev 722)
@@ -109,13 +109,15 @@
 
                 if(withPreModif){
                    main(Param)[] <- .deleteDim(u.theta[idx])
+#                   print(Param)
                    if (lnx) nuisance(Param)[] <- .deleteDim(u.theta[nuis.idx])
+#                   print(Param)
 #                   print(L2Fam)
                    L2Fam <- modifyModel(L2Fam, Param,
                                .withL2derivDistr = L2Fam at .withEvalL2derivDistr)
 #                   print(L2Fam)
                    IC <- modifyIC(IC)(L2Fam, IC)
-#                   print(IC)
+ #                  print(IC)
                 }
 
                 IC.c <- as(diag(p) %*% IC at Curve, "EuclRandVariable")
@@ -126,6 +128,7 @@
                 IC.tot.0 <- NULL
 #                print(Dtau)
                 if(!.isUnitMatrix(Dtau)){
+ #                    print("HU1!")
                      Dminus <- solve(Dtau, generalized = TRUE)
                      projker <- diag(k) - Dminus %*% Dtau
 
@@ -159,6 +162,7 @@
 
                      theta <- (tf$fct(u.theta))$fval
                 }else{
+#                     print("HU2!")
                      correct <- rowMeans(evalRandVar(IC.c, x0), na.rm = na.rm )
                      iM <- is.matrix(theta)
                      names(correct) <- if(iM) rownames(theta) else names(theta)
@@ -173,6 +177,7 @@
                      IC.tot <- IC.c
                      u.theta <- theta
                 }
+#                print("HU3!")
 
                 var0 <- u.var <- NULL
                 if(with.u.var){
@@ -193,7 +198,6 @@
                       if(withEvalAsVar) var0 <- eval(var0)
                    }
                 }
-
                 if(withPostModif){
                    main(Param)[] <- .deleteDim(u.theta[idx])
                    if (lnx) nuisance(Param)[] <- .deleteDim(u.theta[nuis.idx])

Modified: branches/robast-1.0/pkg/RobExtremes/R/getStartIC.R
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/R/getStartIC.R	2014-02-22 23:36:16 UTC (rev 721)
+++ branches/robast-1.0/pkg/RobExtremes/R/getStartIC.R	2014-02-24 17:58:37 UTC (rev 722)
@@ -12,6 +12,8 @@
     scshnm <- scaleshapename(model)
     shnam <- scshnm["shape"]
 
+    ### check whether mc[-1] is a good strategy to delete risk parameter...!!!
+
     nsng <- character(0)
     sng <- try(getFromNamespace(gridn, ns = "RobAStRDA"), silent=TRUE)
     if(!is(sng,"try-error")) nsng <- names(sng)
@@ -19,7 +21,7 @@
        if(nam %in% nsng){
           fctN <- .versionSuff("fun")
           interpolfct <- sng[[nam]][[fctN]]
-          .modifyIC <- function(L2Fam, IC){
+          .modifyIC0 <- function(L2Fam, IC){
                     para <- param(L2Fam)
                     if(!.is.na.Psi(para, interpolfct, shnam))
                        return(.getPsi(para, interpolfct, L2Fam, type(risk)))
@@ -27,6 +29,11 @@
                        return(do.call(getStartIC, as.list(mc[-1]),
                               envir=parent.frame(2)))
           }
+          .modifyIC <- function(L2Fam,IC){
+               psi.0 <- .modifyIC0(L2Fam,IC)
+               psi.0 at modifyIC <- .modifyIC
+               return(psi.0)
+          }
           if(!.is.na.Psi(param1, interpolfct, shnam)){
              IC0 <- .getPsi(param1, interpolfct, model, type(risk))
              IC0 at modifyIC <- .modifyIC


From noreply at r-forge.r-project.org  Mon Feb 24 21:55:47 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Mon, 24 Feb 2014 21:55:47 +0100 (CET)
Subject: [Robast-commits] r723 - in branches/robast-1.0/pkg/RobAStBase: R man
Message-ID: <20140224205547.5BC33186AAA@r-forge.r-project.org>

Author: ruckdeschel
Date: 2014-02-24 21:55:46 +0100 (Mon, 24 Feb 2014)
New Revision: 723

Modified:
   branches/robast-1.0/pkg/RobAStBase/R/comparePlot.R
   branches/robast-1.0/pkg/RobAStBase/R/ddPlot.R
   branches/robast-1.0/pkg/RobAStBase/R/ddPlot_utils.R
   branches/robast-1.0/pkg/RobAStBase/R/infoPlot.R
   branches/robast-1.0/pkg/RobAStBase/R/outlyingPlot.R
   branches/robast-1.0/pkg/RobAStBase/R/plotRescaledAxis.R
   branches/robast-1.0/pkg/RobAStBase/man/ddPlot-methods.Rd
   branches/robast-1.0/pkg/RobAStBase/man/internals_ddPlot.Rd
   branches/robast-1.0/pkg/RobAStBase/man/outlyingPlotIC.Rd
Log:
RobAStBase: fixed some diagnostic plots: 
+ comparePlot now plots the whole range
+ ddPlots / outlyingPlot.R now have alpha transparency and jitter and cex.pts
+ infoPlot plots the correct y-axis (no overplotting)

Modified: branches/robast-1.0/pkg/RobAStBase/R/comparePlot.R
===================================================================
--- branches/robast-1.0/pkg/RobAStBase/R/comparePlot.R	2014-02-24 17:58:37 UTC (rev 722)
+++ branches/robast-1.0/pkg/RobAStBase/R/comparePlot.R	2014-02-24 20:55:46 UTC (rev 723)
@@ -28,7 +28,8 @@
                        expand.dots = FALSE)$"..."
         dotsP <- dots
         dotsLeg <- dotsT <- dotsL <- .makedotsLowLevel(dots)
-
+        dots.points <-   .makedotsPt(dots)
+        
         ncomp <- 2+ (!missing(obj3)|!is.null(obj3)) +
                     (!missing(obj4)|!is.null(obj4))
 
@@ -321,13 +322,21 @@
                 matp  <- cbind(matp,resc4$Y)
             }
 
-            do.call(plot, args=c(list(x = resc1$X, y = matp[,1],
-                 type = plty, lty = lty, col = col[1], lwd = lwd,
-                 xlab = xlab, ylab = ylab), dotsP, list(panel.last = pL)))
-                 
-            do.call(matlines, args = c(list( x = resc1$X, y = matp[,-1],
-                    lty = lty, col = col[-1], lwd = lwd), dotsL))
+            ym <- min(matp,na.rm=T)
+            yM <- max(matp,na.rm=T)
+            y0 <- matp[,1]
+            y0[1:2] <- c(ym,yM)
+            do.call(plot, args=c(list(x = resc1$X, y = y0,
+                 type = "n", xlab = xlab, ylab = ylab,
+                 lty = lty[1], col = addAlphTrsp2col(col[1],0),
+                 lwd = lwd[1]), dotsP, list(panel.last = pL)))
+            if(plty=="p")
+               do.call(matpoints, args = c(list( x = resc1$X, y = matp,
+                    col = col), dots.points))
 
+            do.call(matlines, args = c(list( x = resc1$X, y = matp,
+                    lty = lty, col = col, lwd = lwd), dotsL))
+
             .plotRescaledAxis(scaleX, scaleX.fct, scaleX.inv,
                               scaleY,scaleY.fct, scaleY.inv, xlim[,i],
                               ylim[,i], resc1$X, ypts = 400, n = scaleN,

Modified: branches/robast-1.0/pkg/RobAStBase/R/ddPlot.R
===================================================================
--- branches/robast-1.0/pkg/RobAStBase/R/ddPlot.R	2014-02-24 17:58:37 UTC (rev 722)
+++ branches/robast-1.0/pkg/RobAStBase/R/ddPlot.R	2014-02-24 20:55:46 UTC (rev 723)
@@ -3,7 +3,7 @@
        cutoff.x, cutoff.y, ...,
        cutoff.quantile.x = 0.95, cutoff.quantile.y = cutoff.quantile.x,
        transform.x, transform.y = transform.x,
-       id.n, lab.pts, adj, cex.idn,
+       id.n, cex.pts = 1,lab.pts, jitt.pts = 0, alpha.trsp = NA, adj =0, cex.idn,
        col.idn, lty.cutoff, lwd.cutoff, col.cutoff, text.abline = TRUE,
        text.abline.x = NULL, text.abline.y = NULL,
        cex.abline = par("cex"), col.abline = col.cutoff,
@@ -24,7 +24,7 @@
        cutoff.x, cutoff.y, ...,
        cutoff.quantile.x = 0.95, cutoff.quantile.y = cutoff.quantile.x,
        transform.x, transform.y = transform.x,
-       id.n, lab.pts, adj, cex.idn,
+       id.n, cex.pts = 1,lab.pts, jitt.pts = 0, alpha.trsp = NA, adj =0, cex.idn,
        col.idn, lty.cutoff, lwd.cutoff, col.cutoff, text.abline = TRUE,
        text.abline.x = NULL, text.abline.y = NULL,
        cex.abline = par("cex"), col.abline = col.cutoff,
@@ -45,7 +45,7 @@
        cutoff.x, cutoff.y, ...,
        cutoff.quantile.x = 0.95, cutoff.quantile.y = cutoff.quantile.x,
        transform.x, transform.y = transform.x,
-       id.n, lab.pts, adj, cex.idn,
+       id.n, cex.pts = 1,lab.pts, jitt.pts = 0, alpha.trsp = NA, adj =0, cex.idn,
        col.idn, lty.cutoff, lwd.cutoff, col.cutoff,
        text.abline = TRUE,
        text.abline.x = NULL, text.abline.y = NULL,

Modified: branches/robast-1.0/pkg/RobAStBase/R/ddPlot_utils.R
===================================================================
--- branches/robast-1.0/pkg/RobAStBase/R/ddPlot_utils.R	2014-02-24 17:58:37 UTC (rev 722)
+++ branches/robast-1.0/pkg/RobAStBase/R/ddPlot_utils.R	2014-02-24 20:55:46 UTC (rev 723)
@@ -8,7 +8,10 @@
                                 transform.x,
                                 transform.y = transform.x,
                                 id.n,
+                                cex.pts = 1,
                                 lab.pts,
+                                jitt.pts = 0,
+                                alpha.trsp = NA,
                                 adj =0,
                                 cex.idn = 1,
                                 col.idn = par("col"),
@@ -29,6 +32,12 @@
 
        dots <- match.call(expand.dots = FALSE)$"..."
 
+       jitt.pts <- rep(jitt.pts,length.out=2)
+
+       col <- if(is.null(dots$col)) par("col") else dots$col
+       if(!is.na(alpha.trsp)) col <- addAlphTrsp2col(col, alpha.trsp)
+
+
        id.n1 <- 1:ncol(data)
 
        if(missing(id.n) || is.null(id.n))
@@ -116,6 +125,8 @@
       if(missing(font.abline) && !is.null(dots$font)) font.abline <- dots$font
 
       pdots <- .makedotsLowLevel(dots)
+      pdots$pch <- if(is.null(dots$pch)) "." else dots$pch
+      pdots$cex <- cex.pts
       pdots$xlab <- dots$xlab
       pdots$ylab <- dots$ylab
       pdots$nsim <- NULL
@@ -232,12 +243,16 @@
       id0.x <- id.n1[id.x]
       id0.y <- id.n1[id.y]
 
-      if(any(duplicated(ndata.x)&duplicated(ndata.y))){
-          ndata.x <- jitter(ndata.x, factor=jitt.fac)
-          ndata.y <- jitter(ndata.y, factor=jitt.fac)
-      }
+      ndata.x0 <- ndata.x
+      ndata.y0 <- ndata.y
+      isna <- is.na(ndata.x0)|is.na(ndata.y0)
+      if(any(duplicated(ndata.x0[!isna])))
+          ndata.x0[!isna] <- jitter(ndata.x0[!isna], factor=jitt.pts[1])
+      if(any(duplicated(ndata.y0[!isna])))
+          ndata.y0[!isna] <- jitter(ndata.y0[!isna], factor=jitt.pts[2])
 
-      do.call(plot, args = c(list(x = ndata.x, y=ndata.y, type = "p"), pdots))
+      pdots$col <- col
+      do.call(plot, args = c(list(x = ndata.x0, y=ndata.y0, type = "p"), pdots))
       do.call(box,args=c(adots))
 
       pusr <- par("usr")

Modified: branches/robast-1.0/pkg/RobAStBase/R/infoPlot.R
===================================================================
--- branches/robast-1.0/pkg/RobAStBase/R/infoPlot.R	2014-02-24 17:58:37 UTC (rev 722)
+++ branches/robast-1.0/pkg/RobAStBase/R/infoPlot.R	2014-02-24 20:55:46 UTC (rev 723)
@@ -443,8 +443,8 @@
                    dotsP1))
                do.call(lines, args=c(list(resc$X, resc$Y, type = plty,
                        lty = lty, lwd = lwd, col = col), dotsL))
-               scaleX0 <- (xaxt0[1]!="n")
-               scaleY0 <- (yaxt0[1]!="n")
+               scaleX0 <- scaleX & (xaxt0[1]!="n")
+               scaleY0 <- scaleY & (yaxt0[1]!="n")
                x.ticks0 <- if(xaxt0[1]!="n") x.ticks else NULL
                y.ticks0 <- if(yaxt0[1]!="n") y.ticks[[1]] else NULL
                .plotRescaledAxis(scaleX0, scaleX.fct, scaleX.inv,
@@ -497,8 +497,8 @@
 
                     do.call(lines, args = c(list(resc.C$X, y.vec1C, type = plty,
                             lty = ltyI, col = colI, lwd = lwdI), dotsL))
-                    scaleX0 <- (xaxt0[i+in1to.draw]!="n")
-                    scaleY0 <- (yaxt0[i+in1to.draw]!="n")
+                    scaleX0 <- scaleX & (xaxt0[i+in1to.draw]!="n")
+                    scaleY0 <- scaleY & (yaxt0[i+in1to.draw]!="n")
                     x.ticks0 <- if(xaxt0[i+in1to.draw]!="n") x.ticks else NULL
                     y.ticks0 <- if(yaxt0[i+in1to.draw]!="n") y.ticks[[i+in1to.draw]] else NULL
                     .plotRescaledAxis(scaleX0, scaleX.fct, scaleX.inv,

Modified: branches/robast-1.0/pkg/RobAStBase/R/outlyingPlot.R
===================================================================
--- branches/robast-1.0/pkg/RobAStBase/R/outlyingPlot.R	2014-02-24 17:58:37 UTC (rev 722)
+++ branches/robast-1.0/pkg/RobAStBase/R/outlyingPlot.R	2014-02-24 20:55:46 UTC (rev 723)
@@ -9,8 +9,11 @@
                            cutoff.quantile.x = 0.95,
                            cutoff.quantile.y = cutoff.quantile.x,
                            id.n,
-                           lab.pts, 
-                           adj, 
+                           cex.pts = 1,
+                           lab.pts,
+                           jitt.pts = 0,
+                           alpha.trsp = NA,
+                           adj,
                            cex.idn,
                            col.idn, 
                            lty.cutoff, 
@@ -25,6 +28,7 @@
                            ){
      mc <- as.list(match.call(expand.dots = FALSE))[-1]
      dots <- mc$"..."
+
      if(is.null(dots$xlim)) dots$xlim <- TRUE
      if(is.null(dots$ylim)) dots$ylim <- TRUE
      if(is.null(mc$cutoff.quantile.x)) mc$cutoff.quantile.x <- 0.95
@@ -130,6 +134,8 @@
        transform.y = tf.y,
        id.n = mc$id.n, 
        lab.pts = mc$lab.pts, 
+       alpha.trsp = alpha.trsp,
+       cex.pts = cex.pts,
        adj = mc$adj, 
        cex.idn = mc$cex.idn,
        col.idn = mc$col.idn, 

Modified: branches/robast-1.0/pkg/RobAStBase/R/plotRescaledAxis.R
===================================================================
--- branches/robast-1.0/pkg/RobAStBase/R/plotRescaledAxis.R	2014-02-24 17:58:37 UTC (rev 722)
+++ branches/robast-1.0/pkg/RobAStBase/R/plotRescaledAxis.R	2014-02-24 20:55:46 UTC (rev 723)
@@ -100,7 +100,7 @@
                if(-Inf %in% x.ticks) axis(1,at=0,labels=expression(-infinity))
                if(Inf %in% x.ticks)  axis(1,at=1,labels=expression(infinity))
             }
-            box()
+            if(withbox) box()
         }else{
             if(!is.null(x.ticks)){
                if(is.null(xlim)){ xlim <- c(-Inf,Inf)}else{
@@ -111,7 +111,7 @@
                axis(1,at=xf,labels=xf)
                if(-Inf %in% x.ticks) axis(1,at=0,labels=expression(-infinity))
                if(Inf %in% x.ticks)  axis(1,at=1,labels=expression(infinity))
-               box()
+               if(withbox) box()
             }
         }
         if(scaleY){
@@ -150,7 +150,7 @@
                if(-Inf %in% y.ticks) axis(2,at=0,labels=expression(-infinity))
                if(Inf %in% y.ticks)  axis(2,at=1,labels=expression(infinity))
             }
-            box()
+            if(withbox) box()
         }else{
             if(!is.null(y.ticks)){
                if(is.null(ylim)){ ylim <- c(-Inf,Inf)}else{
@@ -161,7 +161,7 @@
                axis(2,at=yf,labels=yf)
                if(-Inf %in% y.ticks) axis(2,at=0,labels=expression(-infinity))
                if(Inf %in% y.ticks)  axis(2,at=1,labels=expression(infinity))
-               box()
+               if(withbox) box()
            }
         }
    return(invisible(NULL))

Modified: branches/robast-1.0/pkg/RobAStBase/man/ddPlot-methods.Rd
===================================================================
--- branches/robast-1.0/pkg/RobAStBase/man/ddPlot-methods.Rd	2014-02-24 17:58:37 UTC (rev 722)
+++ branches/robast-1.0/pkg/RobAStBase/man/ddPlot-methods.Rd	2014-02-24 20:55:46 UTC (rev 723)
@@ -13,7 +13,7 @@
        cutoff.x, cutoff.y, ...,
        cutoff.quantile.x = 0.95, cutoff.quantile.y = cutoff.quantile.x,
        transform.x, transform.y = transform.x,
-       id.n, lab.pts, adj, cex.idn,
+       id.n, cex.pts = 1,lab.pts, jitt.pts = 0, alpha.trsp = NA, adj =0, cex.idn,
        col.idn, lty.cutoff, lwd.cutoff, col.cutoff, text.abline = TRUE,
        text.abline.x = NULL, text.abline.y = NULL,
        cex.abline = par("cex"), col.abline = col.cutoff,
@@ -27,7 +27,7 @@
        cutoff.x, cutoff.y, ...,
        cutoff.quantile.x = 0.95, cutoff.quantile.y = cutoff.quantile.x,
        transform.x, transform.y = transform.x,
-       id.n, lab.pts, adj, cex.idn,
+       id.n, cex.pts = 1,lab.pts, jitt.pts = 0, alpha.trsp = NA, adj =0, cex.idn,
        col.idn, lty.cutoff, lwd.cutoff, col.cutoff, text.abline = TRUE,
        text.abline.x = NULL, text.abline.y = NULL,
        cex.abline = par("cex"), col.abline = col.cutoff,
@@ -41,7 +41,7 @@
        cutoff.x, cutoff.y, ...,
        cutoff.quantile.x = 0.95, cutoff.quantile.y = cutoff.quantile.x,
        transform.x, transform.y = transform.x,
-       id.n, lab.pts, adj, cex.idn,
+       id.n, cex.pts = 1,lab.pts, jitt.pts = 0, alpha.trsp = NA, adj =0, cex.idn,
        col.idn, lty.cutoff, lwd.cutoff, col.cutoff, text.abline = TRUE,
        text.abline.x = NULL, text.abline.y = NULL,
        cex.abline = par("cex"), col.abline = col.cutoff,
@@ -69,7 +69,18 @@
   distances of the \code{y} axis.}
   \item{id.n}{a set of indices (or a corresponding logical vector); to select a subset
   of the data in argument \code{data}.}
+  \item{cex.pts}{the corresponding \code{cex} argument for plotted points.}
   \item{lab.pts}{a vector of labels for the (unsubsetted) \code{data}.}
+  \item{jitt.pts}{the corresponding \code{jitter} argument for plotted points;
+    may be a vector of length 2 -- for separate factors for x- and y-coordinate.}
+  \item{alpha.trsp}{alpha transparency to be added ex post to colors
+        \code{col.pch} and \code{col.lbl}; if one-dim and NA all colors are
+        left unchanged. Otherwise, with usual recycling rules \code{alpha.trsp}
+        gets shorted/prolongated to length the data-symbols to be plotted.
+        Coordinates of this vector \code{alpha.trsp} with NA are left unchanged,
+        while for the remaining ones, the alpha channel in rgb space is set
+        to the respective coordinate value of \code{alpha.trsp}. The non-NA
+        entries must be integers in [0,255] (0 invisible, 255 opaque).}
   \item{adj}{the corresponding argument for \code{\link[graphics]{text}} for
              labelling the outliers.}
   \item{cex.idn}{the corresponding \code{cex} argument for

Modified: branches/robast-1.0/pkg/RobAStBase/man/internals_ddPlot.Rd
===================================================================
--- branches/robast-1.0/pkg/RobAStBase/man/internals_ddPlot.Rd	2014-02-24 17:58:37 UTC (rev 722)
+++ branches/robast-1.0/pkg/RobAStBase/man/internals_ddPlot.Rd	2014-02-24 20:55:46 UTC (rev 723)
@@ -13,7 +13,7 @@
        cutoff.y = cutoff(norm = dist.y, cutoff.quantile  = cutoff.quantile.y),
        cutoff.quantile.x = 0.95, cutoff.quantile.y = cutoff.quantile.x,
        transform.x, transform.y = transform.x,
-       id.n, lab.pts, adj =0, cex.idn,
+       id.n, cex.pts = 1,lab.pts, jitt.pts = 0, alpha.trsp = NA, adj =0, cex.idn,
        col.idn, lty.cutoff,
        lwd.cutoff, col.cutoff = "red", text.abline = TRUE,
        text.abline.x = NULL, text.abline.y = NULL,
@@ -43,7 +43,18 @@
   distances of the \code{y} axis.}
   \item{id.n}{a set of indices (or a corresponding logical vector); to select a subset
   of the data in argument \code{data}.}
+  \item{cex.pts}{the corresponding \code{cex} argument for plotted points.}
   \item{lab.pts}{a vector of labels for the (unsubsetted) \code{data}.}
+  \item{jitt.pts}{the corresponding \code{jitter} argument for plotted points;
+    may be a vector of length 2 -- for separate factors for x- and y-coordinate.}
+  \item{alpha.trsp}{alpha transparency to be added ex post to colors
+        \code{col.pch} and \code{col.lbl}; if one-dim and NA all colors are
+        left unchanged. Otherwise, with usual recycling rules \code{alpha.trsp}
+        gets shorted/prolongated to length the data-symbols to be plotted.
+        Coordinates of this vector \code{alpha.trsp} with NA are left unchanged,
+        while for the remaining ones, the alpha channel in rgb space is set
+        to the respective coordinate value of \code{alpha.trsp}. The non-NA
+        entries must be integers in [0,255] (0 invisible, 255 opaque).}
   \item{adj}{the corresponding argument for \code{\link[graphics]{text}} for
              labelling the outliers.}
   \item{cex.idn}{the corresponding \code{cex} argument for

Modified: branches/robast-1.0/pkg/RobAStBase/man/outlyingPlotIC.Rd
===================================================================
--- branches/robast-1.0/pkg/RobAStBase/man/outlyingPlotIC.Rd	2014-02-24 17:58:37 UTC (rev 722)
+++ branches/robast-1.0/pkg/RobAStBase/man/outlyingPlotIC.Rd	2014-02-24 20:55:46 UTC (rev 723)
@@ -7,8 +7,9 @@
 outlyingPlotIC(data, IC.x, IC.y = IC.x, dist.x = NormType(),
                dist.y, cutoff.y = cutoff.chisq(), cutoff.x = cutoff.sememp(),
                ..., cutoff.quantile.x = 0.95,
-               cutoff.quantile.y = cutoff.quantile.x, id.n, lab.pts, adj,
-               cex.idn, col.idn, lty.cutoff, lwd.cutoff, col.cutoff,
+               cutoff.quantile.y = cutoff.quantile.x,
+               id.n, cex.pts = 1,lab.pts, jitt.pts = 0, alpha.trsp = NA,
+               adj =0, cex.idn, col.idn, lty.cutoff, lwd.cutoff, col.cutoff,
                robCov.x = TRUE, robCov.y = TRUE, tf.x = data, tf.y = data,
                jitt.fac = 10,
                main = gettext("Outlyingness \n by means of a distance-distance plot")
@@ -31,7 +32,18 @@
   \item{cutoff.quantile.y}{numeric; the cutoff quantile for the \code{y} axis.}
   \item{id.n}{a set of indices (or a corresponding logical vector); to select a subset
   of the data in argument \code{data}.}
+  \item{cex.pts}{the corresponding \code{cex} argument for plotted points.}
   \item{lab.pts}{a vector of labels for the (unsubsetted) \code{data}.}
+  \item{jitt.pts}{the corresponding \code{jitter} argument for plotted points;
+    may be a vector of length 2 -- for separate factors for x- and y-coordinate.}
+  \item{alpha.trsp}{alpha transparency to be added ex post to colors
+        \code{col.pch} and \code{col.lbl}; if one-dim and NA all colors are
+        left unchanged. Otherwise, with usual recycling rules \code{alpha.trsp}
+        gets shorted/prolongated to length the data-symbols to be plotted.
+        Coordinates of this vector \code{alpha.trsp} with NA are left unchanged,
+        while for the remaining ones, the alpha channel in rgb space is set
+        to the respective coordinate value of \code{alpha.trsp}. The non-NA
+        entries must be integers in [0,255] (0 invisible, 255 opaque).}
   \item{adj}{the corresponding argument for \code{\link[graphics]{text}} for
              labelling the outliers.}
   \item{cex.idn}{the corresponding \code{cex} argument for


From noreply at r-forge.r-project.org  Tue Feb 25 12:13:48 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Tue, 25 Feb 2014 12:13:48 +0100 (CET)
Subject: [Robast-commits] r724 - in branches/robast-1.0/pkg/RobExtremes: . R
	man
Message-ID: <20140225111348.C00931866ED@r-forge.r-project.org>

Author: ruckdeschel
Date: 2014-02-25 12:13:48 +0100 (Tue, 25 Feb 2014)
New Revision: 724

Added:
   branches/robast-1.0/pkg/RobExtremes/R/getCVaR.R
   branches/robast-1.0/pkg/RobExtremes/man/getCVaR.Rd
Modified:
   branches/robast-1.0/pkg/RobExtremes/NAMESPACE
Log:
RobExtremes: programmed risk measures VaR, CVaR, and EL for GPD, Weibull, Gamma, ... (ScaleShapeModels)

Modified: branches/robast-1.0/pkg/RobExtremes/NAMESPACE
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/NAMESPACE	2014-02-24 20:55:46 UTC (rev 723)
+++ branches/robast-1.0/pkg/RobExtremes/NAMESPACE	2014-02-25 11:13:48 UTC (rev 724)
@@ -35,6 +35,7 @@
 			  "moveICBackFromRefParam")			  
 
 export("EULERMASCHERONICONSTANT","APERYCONSTANT")
+export("getCVaR", "getVaR", "getEL")
 export("Gumbel", "Pareto", "GPareto", "GEV")
 export("GParetoFamily", "GumbelLocationFamily", "WeibullFamily", "GEVFamily",
        "ParetoFamily", "GEVFamilyMuUnknown")

Added: branches/robast-1.0/pkg/RobExtremes/R/getCVaR.R
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/R/getCVaR.R	                        (rev 0)
+++ branches/robast-1.0/pkg/RobExtremes/R/getCVaR.R	2014-02-25 11:13:48 UTC (rev 724)
@@ -0,0 +1,30 @@
+.getTau <- function(data, model, level, rob=TRUE, of.interest, what){
+  if(rob){
+     est <- roptest(data,model, risk=RMXRRisk())
+     L2FamC <- CallL2Fam(pIC(est))
+  }else{
+     est <- MLEstimator(data,model)
+     IC <- optIC(model,risk=asCov())
+     L2FamC <- CallL2Fam(IC)
+     L2FamC$scale <- estimate(est)["scale"]
+     L2FamC$shape <- estimate(est)["shape"]
+  }
+  eval(what)
+  L2FamC$of.interest <- of.interest # "quantile"
+  L2Fam <- eval(L2FamC)
+  res <- param(L2Fam)@trafo(estimate(est))
+  VaR <- res[[1]]
+  varVaR <- (res[[2]]) %*% asvar(est) %*% t(res[[2]])
+  return(c(VaR=VaR,sqrt(varVaR/length(data))))
+}
+
+getVaR <- function(data, model, level, rob=TRUE)
+             .getTau(data, model, level, rob, of.interest="quantile", substitute(L2FamC$p <- level))
+
+getCVaR <- function(data, model, level, rob=TRUE)
+             .getTau(data, model, level, rob, of.interest="expected shortfall", substitute(L2FamC$p <- level))
+
+getEL <- function(data, model, N0, rob=TRUE)
+             .getTau(data, model, N0, rob, of.interest="expected loss", substitute(L2FamC$N <- N0))
+
+

Added: branches/robast-1.0/pkg/RobExtremes/man/getCVaR.Rd
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/man/getCVaR.Rd	                        (rev 0)
+++ branches/robast-1.0/pkg/RobExtremes/man/getCVaR.Rd	2014-02-25 11:13:48 UTC (rev 724)
@@ -0,0 +1,45 @@
+\name{getCVaR}
+\alias{getVaR}
+\alias{getVaR}
+\alias{getEL}
+
+\title{Risk Measures for Scale-Shape Families}
+\description{
+  Functions to compute Value-at-Risk (VaR), Conditional Value-at-Risk (CVaR)
+  and Expected Loss (EL) at data from scale-shape families.
+}
+\usage{
+getVaR(data, model, level, rob=TRUE)
+getCVaR(data, model, level, rob=TRUE)
+getEL(data, model, N0, rob=TRUE)
+}
+\arguments{
+  \item{data}{data at which to compute the risk measure. }
+  \item{model}{an object of class \code{"L2ScaleShapeFamily"}.
+               The parametric family at which to evaluate the risk measure. }
+  \item{level}{real: probability needed for VaR and CVaR. }
+  \item{N0}{real: expected frequency for expected loss }
+  \item{rob}{logical; if \code{TRUE} (default) the RMXE-parametric estimator is
+             used; otherwise the MLE.}
+ }
+\references{
+P. Ruckdeschel, N. Horbenko (2013): Optimally-Robust Estimators in Generalized
+Pareto Models. Statistics 47(4), 762--791.
+N. Horbenko, P. Ruckdeschel, T. Bae (2011): Robust Estimation of Operational Risk.
+Journal of Operational Risk 6(2), 3--30.
+}
+\author{Peter Ruckdeschel \email{Peter.Ruckdeschel at itwm.fraunhofer.de}}
+\seealso{\code{\link{GParetoFamily}}, \code{\link{GEVFamily}}, \code{\link{WeibullFamily}}, \code{\link{GammaFamily}}}
+\examples{
+  set.seed(123)
+  GPD <- GPartoFamily(loc=20480, scale=7e4, shape=0.3)
+  data <- r(GPD)(500)
+  getVaR(data,GPD,0.99)
+  getVaR(data,GPD,0.99, rob=FALSE)
+  getCVaR(data,GPD,0.99)
+  getCVaR(data,GPD,0.99, rob=FALSE)
+  getEL(data,GPD,5)
+  getEL(data,GPD,5, rob=FALSE)
+}
+\concept{estimator}
+\keyword{risk measure}


From noreply at r-forge.r-project.org  Tue Feb 25 12:17:04 2014
From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org)
Date: Tue, 25 Feb 2014 12:17:04 +0100 (CET)
Subject: [Robast-commits] r725 - branches/robast-1.0/pkg/RobExtremes/man
Message-ID: <20140225111704.4C6651868DF@r-forge.r-project.org>

Author: ruckdeschel
Date: 2014-02-25 12:17:03 +0100 (Tue, 25 Feb 2014)
New Revision: 725

Modified:
   branches/robast-1.0/pkg/RobExtremes/man/getCVaR.Rd
Log:
RobExtremes: added \value tag in getCVaR.Rd

Modified: branches/robast-1.0/pkg/RobExtremes/man/getCVaR.Rd
===================================================================
--- branches/robast-1.0/pkg/RobExtremes/man/getCVaR.Rd	2014-02-25 11:13:48 UTC (rev 724)
+++ branches/robast-1.0/pkg/RobExtremes/man/getCVaR.Rd	2014-02-25 11:17:03 UTC (rev 725)
@@ -22,6 +22,9 @@
   \item{rob}{logical; if \code{TRUE} (default) the RMXE-parametric estimator is
              used; otherwise the MLE.}
  }
+\value{A vector of length 2 with first coordinate the respective risk measure
+and the second a corresponding (asymptotic) standard error for the risk
+measure.}
 \references{
 P. Ruckdeschel, N. Horbenko (2013): Optimally-Robust Estimators in Generalized
 Pareto Models. Statistics 47(4), 762--791.