[Robast-commits] r680 - in branches/robast-0.9/pkg: . 13.07.16 - Wrapper for RobAStBase, RobExtremes
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mon Jul 22 10:09:34 CEST 2013
Author: pupashenko
Date: 2013-07-22 10:09:34 +0200 (Mon, 22 Jul 2013)
New Revision: 680
Added:
branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/
branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/.Rhistory
branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/HelpFunction.R
branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper.R
branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GEV_Trsp100_LegendTrue_rescaleTrue.jpeg
branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GEV_data_Trsp100_LegendTrue_rescaleTrue.jpeg
branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GPD_LegendFalse.jpeg
branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GPD_data_LegendFalse.jpeg
branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Gamma.jpeg
branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Gamma_data.jpeg
branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Weibull_Trsp30_LegendTrue.jpeg
branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Weibull_data_Trsp30_LegendTrue.jpeg
branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/cniperCont.R
branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/cniperPointPlotWrapper.R
branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/cniperPointPlotWrapper_GEV_Lo0_Up5_LegendTrue.jpeg
branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/cniperPointPlotWrapper_GPD_Lo0_Up10_LegendFalse.jpeg
branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/cniperPointPlotWrapper_Gamma_Lo0_Up5.jpeg
branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/cniperPointPlotWrapper_Weibull_LegendTrue.jpeg
branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper.R
branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_GEV_Trsp100_LegendTrue_rescaleTrue_1.jpeg
branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_GEV_Trsp100_LegendTrue_rescaleTrue_2.jpeg
branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_GEV_data_Trsp100_LegendTrue_rescaleTrue_1.jpeg
branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_GEV_data_Trsp100_LegendTrue_rescaleTrue_2.jpeg
branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_GPD_Trsp30_LegendFalse_1.jpeg
branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_GPD_Trsp30_LegendFalse_2.jpeg
branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_GPD_data_Trsp30_LegendFalse_1.jpeg
branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_GPD_data_Trsp30_LegendFalse_2.jpeg
branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_Gamma_1.jpeg
branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_Gamma_2.jpeg
branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_Gamma_data_1.jpeg
branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_Gamma_data_2.jpeg
branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_Weibull_Trsp30_LegendTrue_1.jpeg
branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_Weibull_Trsp30_LegendTrue_2.jpeg
branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_Weibull_data_Trsp30_LegendTrue_1.jpeg
branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_Weibull_data_Trsp30_LegendTrue_2.jpeg
branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/outlyingPlotWrapper.R
branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/outlyingPlotWrapper_GEV_LegendTrue.jpeg
branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/outlyingPlotWrapper_GPD_Trsp50_LegendFalse.jpeg
branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/outlyingPlotWrapper_Gamma_Trsp70.jpeg
branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/outlyingPlotWrapper_Weibull_Trsp30_LegendTrue.jpeg
branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/plotOutlyingness_Old.R
branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/rescaleFunction.R
Log:
New version of Wrappers. Separate function for rescaling is written. Rd comments are added. Some other improvements are also done.
Added: branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/.Rhistory
===================================================================
Added: branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/HelpFunction.R
===================================================================
--- branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/HelpFunction.R (rev 0)
+++ branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/HelpFunction.R 2013-07-22 08:09:34 UTC (rev 680)
@@ -0,0 +1,53 @@
+ myplot <- function(x,y, ..., withCall = TRUE){
+ ###
+ ### 1. grab the dots (and probably manipulate it within the wrapper function)
+ ###
+ mc <- as.list(match.call(expand.dots = FALSE))[-1]
+ dots <- mc$"..."
+ if(is.null(mc$withCall)) mc$withCall <- TRUE
+
+ if(missing(x)) stop("Argument 'x' must be given as argument to 'myplot'")
+ if(missing(y)) stop("Argument 'y' must be given as argument to 'myplot'")
+ ###
+ ## do something to fix the good default arguments
+ ###
+ ### 2. build up the argument list for the (powerful/fullfledged)
+ ### graphics/diagnostics function;
+ ### mind not to evaluate the x and (possibly) y args to provide automatic
+ ### axis annotation
+ ###
+ args <- c(list(x=substitute(x),y=substitute(y)),dots,type="l")
+ print(args)
+ print("###################################################")
+ ###
+ ### 3. build up the call but grab it and write it into an object
+ ###
+ cl <- substitute(do.call(plot,args0), list(args0=args))
+ print(cl)
+ print("###################################################")
+ ### manipulate it so that the wrapper do.call is ommitted
+ cl0 <- as.list(cl)[-1]
+ print(cl0)
+ print("###################################################")
+ mycall <- c(cl0[1],unlist(cl0[-1]))
+ print(mycall)
+ print("###################################################")
+ mycall <- as.call(mycall)
+ print(mycall)
+ print("###################################################")
+ ###
+ ### 4. evaluate the call (i.e., produce the graphic)
+ ###
+ eval(mycall)
+ ###
+ ### 5. return the call (if withCall==TRUE)
+ ###
+ if(mc$withCall) print(mycall)
+
+}
+
+x <- 1:20
+y <- rnorm(20)
+cl <- myplot(x,y,col="red", withCall=TRUE)
+cl <- myplot(x,y,col="blue")
+cl <- myplot(x,y,col="green", withCall=FALSE)
\ No newline at end of file
Added: branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper.R
===================================================================
--- branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper.R (rev 0)
+++ branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper.R 2013-07-22 08:09:34 UTC (rev 680)
@@ -0,0 +1,263 @@
+##########################################
+## ##
+## Wrapper for AllPlot.R ##
+## (plot method for IC) ##
+## ##
+##########################################
+
+### aditional function
+merge.lists <- function(a, b){
+ a.names <- names(a)
+ b.names <- names(b)
+ m.names <- sort(unique(c(a.names, b.names), fromLast = TRUE))
+ sapply(m.names, function(i) {
+ if (is.list(a[[i]]) & is.list(b[[i]])) merge.lists(a[[i]], b[[i]])
+ else if (i %in% b.names) b[[i]]
+ else a[[i]]
+ }, simplify = FALSE)
+}
+
+# WRite the correct path to rescaleFunction.R file for rescaling
+source("D:/Dropbox/My Mathematics/Researches Misha/Current Research/11.06 - KL PhD/PhD Thesis/Reports for Project/13.07.16 - Wrapper for RobAStBase, RobExtremes/rescaleFunction.R")
+
+
+##############################################################
+#' Wrapper function for plot method for IC
+#'
+#' The Wrapper takes most of arguments to the plot method
+#' by default and gives a user possibility to run the
+#' function with low number of arguments
+#'
+#' @param IC object of class \code{IC}
+#'
+#' @param ... additional parameters (in particular to be passed on to \code{plot})
+#'
+#' @param alpha.trsp the transparency argument (0 to 100) for ploting the data
+#'
+#' @param with.legend the flag for showing the legend of the plot
+#'
+#' @param rescale the flag for rescaling the axes for better view of the plot
+#'
+#' @param withCall the flag for the call output
+#'
+#' @usage ICAllPlotWrapper(IC, y,...,alpha.trsp = 100, with.legend = TRUE, rescale = FALSE ,withCall = TRUE)
+#'
+#' @return Plots generated by plot method for IC are returned. If withCall = TRUE, the call of the function is returned
+#'
+#' @export
+#' @docType function
+#' @rdname ICAllPlotWrapper
+#'
+#' @import phylobase
+#' @import vegan
+#' @import igraph
+#' @importFrom multtest mt.maxT
+#' @importFrom multtest mt.minP
+#'
+#' @examples
+#' # GPD
+#' fam = GParetoFamily()
+#' IC <- optIC(model = fam, risk = asCov())
+#' Y=distribution(fam)
+#' y = r(Y)(1000)
+#' ICAllPlotWrapper(IC, y, withCall = FALSE)
+#'
+#' # GEV
+#' fam = GEVFamily()
+#' IC <- optIC(model = fam, risk = asCov())
+#' Y=distribution(fam)
+#' y = r(Y)(1000)
+#' ICAllPlotWrapper(IC, y, rescale = TRUE, withCall = FALSE)
+#'
+#' # Gamma
+#' fam = GammaFamily()
+#' rfam = InfRobModel(fam, ContNeighborhood(0.5))
+#' IC <- optIC(model = fam, risk = asCov())
+#' Y=distribution(fam)
+#' y = r(Y)(1000)
+#' ICAllPlotWrapper(IC, y, withCall = FALSE)
+#'
+#' # Weibull
+#' fam = WeibullFamily()
+#' IC <- optIC(model = fam, risk = asCov())
+#' Y=distribution(fam)
+#' y = r(Y)(1000)
+#' ICAllPlotWrapper(IC, y, withCall = FALSE)
+##############################################################
+
+##IC - influence curve
+##y - dataset
+## with.legend - optional legend indicator
+## withCall - optional indicator of the function call
+#
+ICAllPlotWrapper = function(IC, y,...,alpha.trsp = 100, with.legend = TRUE, rescale = FALSE ,withCall = TRUE){
+ ###
+ ### 1. grab the dots (and manipulate it within the wrapper function)
+ ###
+ ###
+ ### do something to fix the good default arguments
+ ###
+ if(missing(IC)) stop("Argument 'IC' must be given as argument to 'ICAllPlotWrapper'")
+ mc <- as.list(match.call(expand.dots = FALSE))[-1]
+ dots <- mc$"..."
+ if(missing(y)){
+ alpha.trsp <- 100
+ } else {
+ if(is.null(mc$alpha.trsp)){
+ alpha.trsp <- 30
+ if(length(y) < 1000){
+ alpha.trsp <- 50
+ }
+ if(length(y) < 100){
+ alpha.trsp <- 100
+ }
+ }
+ }
+ if(is.null(mc$with.legend)) mc$with.legend <- TRUE
+ if(is.null(mc$rescale)) mc$rescale <- FALSE
+ if(is.null(mc$withCall)) mc$withCall <- TRUE
+ ###
+ ### 2. build up the argument list for the (powerful/fullfledged)
+ ### graphics/diagnostics function;
+ ##
+
+ ## Scaling of the axes
+ scaleList <- rescaleFunction(as.list(IC at CallL2Fam)[[1]], !missing(y), mc$rescale)
+
+ if(missing(y)){
+ argsList <- c(list(x = substitute(IC)
+ ,withSweave = substitute(getdistrOption("withSweave"))
+ ,main = substitute(FALSE)
+ ,inner = substitute(TRUE)
+ ,sub = substitute(FALSE)
+ ,col.inner = substitute(par("col.main"))
+ ,cex.inner = substitute(0.8)
+ ,bmar = substitute(par("mar")[1])
+ ,tmar = substitute(par("mar")[3])
+ ,with.legend = substitute(FALSE)
+ ,legend = substitute(NULL)
+ ,legend.bg = substitute("white")
+ ,legend.location = substitute("bottomright")
+ ,legend.cex = substitute(0.8)
+ ,withMBR = substitute(FALSE)
+ ,MBRB = substitute(NA)
+ ,MBR.fac = substitute(2)
+ ,col.MBR = substitute(par("col"))
+ ,lty.MBR = substitute("dashed")
+ ,lwd.MBR = substitute(0.8)
+ ,scaleN = substitute(9)
+ ,mfColRow = substitute(TRUE)
+ ,to.draw.arg = substitute(NULL)
+ ,adj = substitute(0.5)
+ ,cex.main = substitute(1.5)
+ ,cex.lab = substitute(1.5)
+ ,cex = substitute(1.5)
+ ,bty = substitute("o")
+ ,panel.first= substitute(grid())
+ ,col = substitute("blue")
+ ), scaleList)
+ }else{
+ argsList <- c(list(x = substitute(IC)
+ ,y = substitute(y)
+ ,cex.pts = substitute(0.3)
+ ,col.pts = substitute(addAlphTrsp2col(rgb(0,255,0,maxColorValue=255), substitute(alpha.trsp)))
+ ,pch.pts = substitute(1)
+ ,jitter.fac = substitute(1)
+ ,with.lab = substitute(FALSE)
+ ,lab.pts = substitute(NULL)
+ ,lab.font = substitute(NULL)
+ ,alpha.trsp = substitute(NA)
+ ,which.lbs = substitute(NULL)
+ ,which.Order = substitute(NULL)
+ ,return.Order = substitute(FALSE)
+ ,scaleN = substitute(9)
+ ,adj = substitute(0.5)
+ ,cex.main = substitute(1.5)
+ ,cex.lab = substitute(1.5)
+ ,cex = substitute(1.5)
+ ,bty = substitute("o")
+ ,panel.first= substitute(grid())
+ ,col = substitute("blue")
+ ), scaleList)
+ }
+
+ ##parameter for plotting
+ if(mc$with.legend)
+ {
+ argsList$col.main <- "black"
+ argsList$col.lab <- "black"
+ }
+ else
+ {
+ argsList$col.main <- "white"
+ argsList$col.lab <- "white"
+ }
+
+ args <- merge.lists(argsList, dots)
+ ###
+ ### 3. build up the call but grab it and write it into an object
+ ###
+ cl <- substitute(do.call(plot,args0), list(args0=args))
+ ### manipulate it so that the wrapper do.call is ommitted
+ cl0 <- as.list(cl)[-1]
+ mycall <- c(cl0[1],unlist(cl0[-1]))
+ mycall <- as.call(mycall)
+ ###
+ ### 4. evaluate the call (i.e., produce the graphic)
+ ###
+ eval(mycall)
+ ###
+ ### 5. return the call (if withCall==TRUE)
+ ###
+ if(mc$withCall) print(mycall)
+
+}
+
+##Examples
+require(RobExtremes)
+require(distr)
+
+# GPD
+fam = GParetoFamily()
+IC <- optIC(model = fam, risk = asCov())
+Y=distribution(fam)
+y = r(Y)(1000)
+# dev.new()
+# ICAllPlotWrapper(IC, with.legend = FALSE)
+dev.new()
+ICAllPlotWrapper(IC, y, withCall = FALSE)
+
+# GEV
+fam = GEVFamily()
+IC <- optIC(model = fam, risk = asCov())
+Y=distribution(fam)
+y = r(Y)(1000)
+# dev.new()
+# ICAllPlotWrapper(IC, alpha.trsp=100, with.legend = TRUE, rescale = TRUE, withCall = TRUE)
+dev.new()
+ICAllPlotWrapper(IC, y, rescale = TRUE, withCall = FALSE)
+
+# Gamma
+fam = GammaFamily()
+rfam = InfRobModel(fam, ContNeighborhood(0.5))
+IC <- optIC(model = fam, risk = asCov())
+# ICr <- optIC(model = rfam, risk = asBias())
+Y=distribution(fam)
+y = r(Y)(1000)
+# dev.new()
+# ICAllPlotWrapper(IC)
+# dev.new()
+# ICAllPlotWrapper(ICr)
+dev.new()
+ICAllPlotWrapper(IC, y, withCall = FALSE)
+
+# Weibull
+fam = WeibullFamily()
+IC <- optIC(model = fam, risk = asCov())
+Y=distribution(fam)
+y = r(Y)(1000)
+# dev.new()
+# ICAllPlotWrapper(IC, alpha.trsp=30, with.legend = TRUE, withCall = FALSE)
+dev.new()
+ICAllPlotWrapper(IC, y, withCall = FALSE)
+
Added: branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GEV_Trsp100_LegendTrue_rescaleTrue.jpeg
===================================================================
(Binary files differ)
Property changes on: branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GEV_Trsp100_LegendTrue_rescaleTrue.jpeg
___________________________________________________________________
Added: svn:mime-type
+ application/octet-stream
Added: branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GEV_data_Trsp100_LegendTrue_rescaleTrue.jpeg
===================================================================
(Binary files differ)
Property changes on: branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GEV_data_Trsp100_LegendTrue_rescaleTrue.jpeg
___________________________________________________________________
Added: svn:mime-type
+ application/octet-stream
Added: branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GPD_LegendFalse.jpeg
===================================================================
(Binary files differ)
Property changes on: branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GPD_LegendFalse.jpeg
___________________________________________________________________
Added: svn:mime-type
+ application/octet-stream
Added: branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GPD_data_LegendFalse.jpeg
===================================================================
(Binary files differ)
Property changes on: branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GPD_data_LegendFalse.jpeg
___________________________________________________________________
Added: svn:mime-type
+ application/octet-stream
Added: branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Gamma.jpeg
===================================================================
(Binary files differ)
Property changes on: branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Gamma.jpeg
___________________________________________________________________
Added: svn:mime-type
+ application/octet-stream
Added: branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Gamma_data.jpeg
===================================================================
(Binary files differ)
Property changes on: branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Gamma_data.jpeg
___________________________________________________________________
Added: svn:mime-type
+ application/octet-stream
Added: branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Weibull_Trsp30_LegendTrue.jpeg
===================================================================
(Binary files differ)
Property changes on: branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Weibull_Trsp30_LegendTrue.jpeg
___________________________________________________________________
Added: svn:mime-type
+ application/octet-stream
Added: branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Weibull_data_Trsp30_LegendTrue.jpeg
===================================================================
(Binary files differ)
Property changes on: branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Weibull_data_Trsp30_LegendTrue.jpeg
___________________________________________________________________
Added: svn:mime-type
+ application/octet-stream
Added: branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/cniperCont.R
===================================================================
--- branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/cniperCont.R (rev 0)
+++ branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/cniperCont.R 2013-07-22 08:09:34 UTC (rev 680)
@@ -0,0 +1,252 @@
+.rescalefct <- RobAStBase:::.rescalefct
+.plotRescaledAxis <- RobAStBase:::.plotRescaledAxis
+.makedotsP <- RobAStBase:::.makedotsP
+.makedotsLowLevel <- RobAStBase:::.makedotsLowLevel
+.SelectOrderData <- RobAStBase:::.SelectOrderData
+
+.plotData <- function(
+ ## helper function for cniper-type plots to plot in data
+ data, # data to be plot in
+ dots, # dots from the calling function
+ origCl, # call from the calling function
+ fun, # function to determine risk difference
+ L2Fam, # L2Family
+ IC # IC1 in cniperContPlot and eta in cniperPointPlot
+){
+ dotsP <- .makedotsP(dots)
+ dotsP$col <- rep(eval(origCl$col.pts), length.out=n)
+ dotsP$pch <- rep(eval(origCl$pch.pts), length.out=n)
+
+ al <- eval(origCl$alpha.trsp)
+ if(!is.na(al))
+ dotsP$col <- sapply(dotsP$col, addAlphTrsp2col, alpha=al)
+
+ n <- if(!is.null(dim(data))) nrow(data) else length(data)
+ if(!is.null(lab.pts))
+ lab.pts <- rep(origCl$lab.pts, length.out=n)
+
+ sel <- .SelectOrderData(data, function(x)sapply(x,fun),
+ eval(origCl$which.lbs),
+ eval(origCl$which.Order))
+ i.d <- sel$ind
+ i0.d <- sel$ind1
+ y.d <- sel$y
+ x.d <- sel$data
+ n <- length(i.d)
+
+ resc.dat <- .rescalefct(x.d, function(x) sapply(x,fun),
+ eval(origCl$scaleX), origCl$scaleX.fct, origCl$scaleX.inv,
+ eval(origCl$scaleY), origCl$scaleY.fct,
+ dots$xlim, dots$ylim, dots)
+
+ dotsP$x <- resc.dat$X
+ dotsP$y <- resc.dat$Y
+
+ trafo <- trafo(L2Fam at param)
+ dims <- nrow(trafo)
+ QF <- diag(dims)
+ if(is(IC,"ContIC") & dims>1 )
+ {if (is(normtype(IC),"QFNorm"))
+ QF <- QuadForm(normtype(IC))}
+
+ absInfoEval <- function(x,y) sapply(x, y at Map[[1]])
+ IC.rv <- as(diag(dims) %*% IC at Curve, "EuclRandVariable")
+ absy.f <- t(IC.rv) %*% QF %*% IC.rv
+ absy <- absInfoEval(x.d, absy.f)
+
+ if(is.null(origCl$cex.pts)) origCl$cex.pts <- par("cex")
+ dotsP$cex <- log(absy+1)*3*rep(origCl$cex.pts, length.out=n)
+
+ dotsT <- dotsP
+ dotsT$pch <- NULL
+ dotsT$cex <- dotsP$cex/2
+ dotsT$labels <- if(is.null(lab.pts)) i.d else lab.pts[i.d]
+ do.call(points,dotsP)
+ if(!is.null(origCl$with.lab))
+ if(origCl$with.lab) do.call(text,dotsT)
+ if(!is.null(origCl$return$order))
+ if(origCl$return.Order) return(i0.d)
+ return(invisible(NULL))
+ }
+
+
+.getFunCnip <- function(IC1,IC2, risk, L2Fam, r, b20=NULL){
+
+ riskfct <- getRiskFctBV(risk, biastype(risk))
+
+ .getTrVar <- function(IC){
+ R <- Risks(IC)[["trAsCov"]]
+ if(is.null(R)) R <- getRiskIC(IC, risk = trAsCov(), L2Fam = L2Fam)
+ if(length(R) > 1) R <- R$value
+ return(R)
+ }
+ 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))
+ }
+ r1 - r2
+ }
+
+ return(fun)
+}
+
+cniperCont <- function(IC1, IC2, data = NULL, ...,
+ neighbor, risk, lower=getdistrOption("DistrResolution"),
+ upper=1-getdistrOption("DistrResolution"), n = 101,
+ scaleX = FALSE, scaleX.fct, scaleX.inv,
+ scaleY = FALSE, scaleY.fct = pnorm, scaleY.inv=qnorm,
+ scaleN = 9, x.ticks = NULL, y.ticks = NULL,
+ cex.pts = 1, col.pts = par("col"),
+ pch.pts = 1, jitter.fac = 1, with.lab = FALSE,
+ lab.pts = NULL, lab.font = NULL, alpha.trsp = NA,
+ which.lbs = NULL, which.Order = NULL,
+ return.Order = FALSE){
+
+ mc <- match.call(expand.dots = FALSE)
+ dots <- as.list(mc$"...")
+ if(!is(IC1,"IC")) stop ("IC1 must be of class 'IC'")
+ if(!is(IC2,"IC")) stop ("IC2 must be of class 'IC'")
+ if(!identical(IC1 at CallL2Fam, IC2 at CallL2Fam))
+ stop("IC1 and IC2 must be defined on the same model")
+
+ L2Fam <- eval(IC1 at CallL2Fam)
+
+ b20 <- NULL
+ fCpl <- eval(dots$fromCniperPlot)
+ if(!is.null(fCpl))
+ if(fCpl) b20 <- neighbor at radius*Risks(IC2)$asBias$value
+ dots$fromCniperPlot <- NULL
+
+ dots <- as.list(dots$"...") #!!!#otherwise extra parameters from cniperPointPlotWrapper appear to be in the $...$ field of dots
+
+ fun <- .getFunCnip(IC1,IC2, risk, L2Fam, neighbor at radius, b20)
+
+ if(missing(scaleX.fct)){
+ scaleX.fct <- p(L2Fam)
+ 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)
+ 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
+ dots$y <- resc$Y
+
+
+ dots$type <- "l"
+ if(is.null(dots$main)) dots$main <- gettext("Cniper region plot")
+ if(is.null(dots$xlab)) dots$xlab <- gettext("Dirac point")
+ if(is.null(dots$ylab))
+ dots$ylab <- gettext("Asymptotic Risk difference (IC1 - IC2)")
+
+ colSet <- ltySet <- lwdSet <- FALSE
+ if(!is.null(dots$col)) {colSet <- TRUE; colo <- eval(dots$col)}
+ if(colSet) {
+ colo <- rep(colo,length.out=2)
+ dots$col <- colo[1]
+ }
+ if(!is.null(dots$lwd)) {lwdSet <- TRUE; lwdo <- eval(dots$lwd)}
+ if(lwdSet) {
+ lwdo <- rep(lwdo,length.out=2)
+ dots$lwd <- lwdo[1]
+ }
+ if(!is.null(dots$lty)) {ltySet <- TRUE; ltyo <- eval(dots$lty)}
+ if(ltySet && ((!is.numeric(ltyo) && length(ltyo)==1)||
+ is.numeric(ltyo))){
+ ltyo <- list(ltyo,ltyo)
+ dots$lty <- ltyo[[1]]
+ }else{ if (ltySet && !is.numeric(ltyo) && length(ltyo)==2){
+ dots$lty <- ltyo[[1]]
+ }
+ }
+ do.call(plot,dots)
+
+ dots <- .makedotsLowLevel(dots)
+ dots$x <- dots$y <- NULL
+ if(colSet) dots$col <- colo[2]
+ if(lwdSet) dots$lwd <- lwdo[2]
+ if(ltySet) dots$lty <- ltyo[[2]]
+
+ dots$h <- if(scaleY) scaleY.fct(0) else 0
+ do.call(abline, dots)
+
+ .plotRescaledAxis(scaleX, scaleX.fct, scaleX.inv, scaleY,scaleY.fct,
+ scaleY.inv, dots$xlim, dots$ylim, resc$X, ypts = 400,
+ n = scaleN, x.ticks = x.ticks, y.ticks = y.ticks)
+ if(!is.null(data))
+ return(.plotData(data, dots, mc, fun, L2Fam, IC1))
+ invisible(NULL)
+}
+
+cniperPoint <- function(L2Fam, neighbor, risk= asMSE(),
+ lower=getdistrOption("DistrResolution"),
+ upper=1-getdistrOption("DistrResolution")){
+
+
+ mc <- match.call(expand.dots = FALSE)
+
+ if(!is.null(as.list(mc)$lower)) lower <- p(L2Fam)(lower)
+ if(!is.null(as.list(mc)$upper)) upper <- p(L2Fam)(upper)
+ lower <- q(L2Fam)(lower)
+ upper <- q(L2Fam)(upper)
+
+ robMod <- InfRobModel(center = L2Fam, neighbor = neighbor)
+
+ psi <- optIC(model = L2Fam, risk = asCov())
+ eta <- optIC(model = robMod, risk = risk)
+
+ fun <- .getFunCnip(psi,eta, risk, L2Fam, neighbor at radius)
+
+ res <- uniroot(fun, lower = lower, upper = upper)$root
+ names(res) <- "cniper point"
+ res
+}
+
+cniperPointPlot <- function(L2Fam, data=NULL, ..., neighbor, risk= asMSE(),
+ lower=getdistrOption("DistrResolution"),
+ upper=1-getdistrOption("DistrResolution"), n = 101,
+ withMaxRisk = TRUE,
+ scaleX = FALSE, scaleX.fct, scaleX.inv,
+ scaleY = FALSE, scaleY.fct = pnorm, scaleY.inv=qnorm,
+ scaleN = 9, x.ticks = NULL, y.ticks = NULL,
+ cex.pts = 1, col.pts = par("col"),
+ pch.pts = 1, jitter.fac = 1, with.lab = FALSE,
+ lab.pts = NULL, lab.font = NULL, alpha.trsp = NA,
+ which.lbs = NULL, which.Order = NULL,
+ return.Order = FALSE){
+
+ mc <- as.list(match.call(expand.dots = FALSE))[-1] #!!!#otherwise the match.call works incorrectly, it takes the call of cniperPointPlotWrapper function instead
+#!!!# mc <- match.call(call = sys.call(sys.parent(1)),
+#!!!# expand.dots = FALSE)
+ mcl <- as.list(mc[-1])
+ dots <- as.list(mc$"...")
+
+ robMod <- InfRobModel(center = L2Fam, neighbor = neighbor)
+
+ mcl$IC1 <- optIC(model = L2Fam, risk = asCov())
+ mcl$IC2 <- optIC(model = robMod, risk = risk)
+ mcl$L2Fam <- NULL
+ mcl$withMaxRisk <- NULL #!!!#otherwise it passed to dots in cniperCont and recognized as a graphical parameter
+ if(is.null(dots$ylab))
+ mcl$ylab <- gettext("Asymptotic Risk difference (classic - robust)")
+ if(is.null(dots$main))
+ mcl$main <- gettext("Cniper point plot")
+
+ if(withMaxRisk) mcl$fromCniperPlot <- TRUE
+ do.call(cniperCont, mcl)
+}
+
+
+
Added: branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/cniperPointPlotWrapper.R
===================================================================
--- branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/cniperPointPlotWrapper.R (rev 0)
+++ branches/robast-0.9/pkg/13.07.16 - Wrapper for RobAStBase, RobExtremes/cniperPointPlotWrapper.R 2013-07-22 08:09:34 UTC (rev 680)
@@ -0,0 +1,195 @@
+##########################################
+## ##
+## Wrapper for cniperPointPlot.R ##
+## ##
+## ##
+##########################################
+
+### aditional function
+merge.lists <- function(a, b){
+ a.names <- names(a)
+ b.names <- names(b)
+ m.names <- sort(unique(c(a.names, b.names), fromLast = TRUE))
+ sapply(m.names, function(i) {
+ if (is.list(a[[i]]) & is.list(b[[i]])) merge.lists(a[[i]], b[[i]])
+ else if (i %in% b.names) b[[i]]
+ else a[[i]]
+ }, simplify = FALSE)
+}
+
+##############################################################
+#' Wrapper function for cniperPointPlot - Computation and Plot
+#' of Cniper Contamination and Cniper Points
+#'
+#' The Wrapper takes most of arguments to the cniperPointPlot
+#' function by default and gives a user possibility to run the
+#' function with low number of arguments
+#'
+#' @param fam object of class L2ParamFamily
+#'
+#' @param ... additional parameters (in particular to be passed on to \code{plot})
+#'
+#' @param lower the lower end point of the contamination interval
+#'
+#' @param upper the upper end point of the contamination interval
+#'
+#' @param with.legend the flag for showing the legend of the plot
+#'
+#' @param withCall the flag for the call output
+#'
+#' @usage cniperPointPlotWrapper(fam,...,lower = getdistrOption("DistrResolution"),upper=1-getdistrOption("DistrResolution"),with.legend = TRUE, withCall = TRUE)
+#'
+#' @return Plot generated by cniperPointPlot is returned. If withCall = TRUE, the call of the function is returned
+#'
+#' @export
+#' @docType function
+#' @rdname cniperPointPlotWrapper
+#'
+#' @import phylobase
+#' @import vegan
+#' @import igraph
+#' @importFrom multtest mt.maxT
+#' @importFrom multtest mt.minP
+#'
+#' @examples
+#' # GPD
+#' fam = GParetoFamily()
+#' cniperPointPlotWrapper(fam=fam, main = "GPD", lower = 0, upper = 10, withCall = FALSE)
+#' # GEV
+#' fam = GEVFamily()
+#' cniperPointPlotWrapper(fam=fam, main = "GEV", lower = 0, upper = 5, withCall = FALSE)
+#' # Gamma
+#' fam = GammaFamily()
+#' cniperPointPlotWrapper(fam=fam, main = "Gamma", lower = 0, upper = 5, withCall = FALSE)
+#' # Weibull
+#' fam = WeibullFamily()
+#' cniperPointPlotWrapper(fam=fam, main = "Weibull", withCall = FALSE)
+##############################################################
+
+##@fam - parameter family
+## lower - left point of the x-axis
+## upper - right point of the x-axis
+## alpha.trsp - optional transparency of the plot
+## with.legend - optional legend indicator
+## withCall - optional indicator of the function call
+#
+cniperPointPlotWrapper = function(fam,...
+ ,lower = getdistrOption("DistrResolution")
+ ,upper=1-getdistrOption("DistrResolution")
+ ,with.legend = TRUE, withCall = TRUE){
+ ###
+ ### 1. grab the dots (and manipulate it within the wrapper function)
+ ###
+ ###
+ ### do something to fix the good default arguments
+ ###
+ mc <- as.list(match.call(expand.dots = FALSE))[-1]
+ dots <- mc$"..."
+ if(is.null(mc$lower)) lower <- getdistrOption("DistrResolution")
+ if(is.null(mc$upper)) upper <- 1-getdistrOption("DistrResolution")
+ if(is.null(mc$with.legend)) mc$with.legend <- TRUE
+ if(is.null(mc$withCall)) mc$withCall <- TRUE
+ if(missing(fam)) stop("Argument 'fam' must be given as argument to 'cniperPointPlotWrapper'")
+ ###
+ ### 2. build up the argument list for the (powerful/fullfledged)
+ ### graphics/diagnostics function;
+ ##
+
+ argsList <- list(L2Fam = substitute(fam)
+ ,data = substitute(NULL)
+ ,neighbor = substitute(ContNeighborhood(radius = 0.5))
+ ,risk = substitute(asMSE())
+ ,lower = substitute(lower)
+ ,upper = substitute(upper)
+ ,n = substitute(101)
+ ,withMaxRisk = substitute(TRUE)
+ ,scaleX = substitute(FALSE)
+ ,scaleX.fct = substitute(p(fam))
+ ,scaleX.inv = substitute(q(fam))
+ ,scaleY = substitute(FALSE)
+ ,scaleY.fct = substitute(pnorm)
+ ,scaleY.inv = substitute(qnorm)
+ ,scaleN = substitute(9)
+ ,x.ticks = substitute(NULL)
+ ,y.ticks = substitute(NULL)
+ ,cex.pts = substitute(1)
+ ,col.pts = substitute(par("col"))
+ ,pch.pts = substitute(1)
+ ,jitter.fac = substitute(1)
+ ,with.lab = substitute(FALSE)
+ ,lab.pts = substitute(NULL)
+ ,lab.font = substitute(NULL)
+ ,alpha.trsp = substitute(NA)
+ ,which.lbs = substitute(NULL)
+ ,which.Order = substitute(NULL)
+ ,return.Order = substitute(FALSE)
+ ,adj = 0.5
+ ,cex.main = substitute(1.5)
+ ,cex.lab = substitute(1.5)
+ ,main = ""#"Outlyingness Plot"
+ ,xlab=substitute("Dirac point")
+ ,ylab=substitute("Asymptotic Risk difference (classic - robust)")
+ ,bty = substitute("o")
+ )
+
+ ##parameter for plotting
+ if(mc$with.legend)
+ {
+ argsList$col.main <- "black"
+ argsList$col.lab <- "black"
+ }
+ else
+ {
+ argsList$col.main <- "white"
+ argsList$col.lab <- "white"
+ }
+
+ args <- merge.lists(argsList, dots)
+ ###
+ ### 3. build up the call but grab it and write it into an object
+ ###
+ cl <- substitute(do.call(cniperPointPlot,args0), list(args0=args))
+ ### manipulate it so that the wrapper do.call is ommitted
+ cl0 <- as.list(cl)[-1]
+ mycall <- c(cl0[1],unlist(cl0[-1]))
+ mycall <- as.call(mycall)
+ ###
+ ### 4. evaluate the call (i.e., produce the graphic)
+ ###
+ eval(mycall)
+ ###
+ ### 5. return the call (if withCall==TRUE)
+ ###
+ if(mc$withCall) print(mycall)
+
+}
+
+##Examples
+require(RobExtremes)
+require(distr)
+
+# WRite the correct path to the modified file cniperCont.R from the ROptEst package
+source("D:/Dropbox/My Mathematics/Researches Misha/Current Research/11.06 - KL PhD/PhD Thesis/Reports for Project/13.07.16 - Wrapper for RobAStBase, RobExtremes/cniperCont.R")
+
+# GPD
+dev.new()
+fam = GParetoFamily()
+cniperPointPlotWrapper(fam=fam, main = "GPD", lower = 0, upper = 10, withCall = FALSE)
+
+# GEV
+dev.new()
+fam = GEVFamily()
+cniperPointPlotWrapper(fam=fam, main = "GEV", lower = 0, upper = 5, withCall = FALSE)
+
+# Gamma
+dev.new()
+fam = GammaFamily()
+cniperPointPlotWrapper(fam=fam, main = "Gamma", lower = 0, upper = 5, withCall = FALSE)
+
+# Weibull
+dev.new()
+fam = WeibullFamily()
+cniperPointPlotWrapper(fam=fam, main = "Weibull", withCall = FALSE)
+
+
+
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/robast -r 680
More information about the Robast-commits
mailing list