[Robast-commits] r667 - in branches/robast-0.9/pkg: . 13.05.31 - Wrapper for RobAStBase, RobExtremes
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri May 31 09:23:55 CEST 2013
Author: pupashenko
Date: 2013-05-31 09:23:55 +0200 (Fri, 31 May 2013)
New Revision: 667
Added:
branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/
branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/.Rhistory
branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/HelpFunction.R
branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper.R
branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GEV_LegendTrue.jpeg
branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GEV_data_LegendTrue.jpeg
branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GPD_Trsp50_LegendFalse.jpeg
branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GPD_data_Trsp50_LegendFalse.jpeg
branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Gamma_Trsp70.jpeg
branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Gamma_data_Trsp70.jpeg
branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Weibull_Trsp50_LegendTrue.jpeg
branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Weibull_data_Trsp50_LegendTrue.jpeg
branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/cniperCont.R
branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/cniperPointPlotWrapper.R
branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/cniperPointPlotWrapper_GEV_Lo0_Up5_LegendTrue.jpeg
branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/cniperPointPlotWrapper_GPD_Lo0_Up10_LegendFalse.jpeg
branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/cniperPointPlotWrapper_Gamma_Lo0_Up5.jpeg
branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/cniperPointPlotWrapper_Weibull_LegendTrue.jpeg
branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper.R
branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_GEV_LegendTrue_1.jpeg
branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_GEV_LegendTrue_2.jpeg
branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_GEV_data_LegendTrue_1.jpeg
branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_GEV_data_LegendTrue_2.jpeg
branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_GPD_Trsp50_LegendFalse_1.jpeg
branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_GPD_Trsp50_LegendFalse_2.jpeg
branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_GPD_data_Trsp50_LegendFalse_1.jpeg
branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_GPD_data_Trsp50_LegendFalse_2.jpeg
branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_Gamma_Trsp70_1.jpeg
branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_Gamma_Trsp70_2.jpeg
branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_Gamma_data_Trsp70_1.jpeg
branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_Gamma_data_Trsp70_2.jpeg
branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_Weibull_Trsp50_LegendTrue_1.jpeg
branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_Weibull_Trsp50_LegendTrue_2.jpeg
branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_Weibull_data_Trsp50_LegendTrue_1.jpeg
branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/infoPlotWrapper_Weibull_data_Trsp50_LegendTrue_2.jpeg
branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/outlyingPlotWrapper.R
branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/outlyingPlotWrapper_GEV_Trsp100_LegendTrue.jpeg
branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/outlyingPlotWrapper_GPD_Trsp50_LegendFalse.jpeg
branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/outlyingPlotWrapper_Gamma_Trsp70.jpeg
branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/outlyingPlotWrapper_Weibull_Trsp50_LegendTrue.jpeg
branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/plotOutlyingness_Old.R
Log:
Die Wrapper Funktionen f?\195?\188r plot Methode (f?\195?\188r IC, in AllPlot?.R), InfoPlot Methode, outlyingPlot, cniperPointPlot. Extra Modifikation ist gemacht f?\195?\188r cniperCont.R File, damit die Wrappern richtig funktionieren k?\195?\182nnen. Die Beispiele sind auch gemacht.
Added: branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/.Rhistory
===================================================================
--- branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/.Rhistory (rev 0)
+++ branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/.Rhistory 2013-05-31 07:23:55 UTC (rev 667)
@@ -0,0 +1,512 @@
+,cutoff.quantile.y = cutoff.quantile.y
+,cutoff.x = cutoff()
+,cutoff.y = cutoff.sememp()
+,robCov.x = TRUE
+,robCov.y = TRUE
+,tf.x = function(x)log(x)
+,cex.main = 1.5
+,cex.lab = 1.5
+,cex = 1.5
+#,col.lab=FhGred
+,lwd.cutoff = 3
+#,jitt.fac = 300
+,col.abline = col.abline
+,cex.abline = 1.2
+,adj.abline = c(0.8, 0.2)
+,main = ""#"Outlyingness Plot"
+,xlab="Theoretical log-quantiles"
+,ylab="Mahalanobis distance"
+)
+}
+##Example
+require(RobExtremes)
+X = GPareto()
+fam = GParetoFamily()
+x = r(X)(1000)
+plotOutlyingness(x,alpha=0.95,fam=fam,alpha.trsp=75, with.legend = TRUE)
+plotOutlyingness(x,alpha=0.99,fam=fam, with.legend = FALSE)
+##########################################
+## ##
+## Wrapper for outlyingnessPlot.R ##
+## ##
+## ##
+##########################################
+##projection distance
+qfun = function(x){p0 = p(X)(x); q0 = q(X)(p0)}
+QProj <- function(){new("NormType", name="Quantiles", fct=qfun)}
+##@x - dataset
+##@X - random variable
+##@fam - parameter family
+##@alpha - confidence level for quantile
+#
+plotOutlyingness = function(x,alpha=0.99,fam=GParetoFamily(),...,alpha.trsp = 100, with.legend = TRUE){
+mc <- as.list(match.call(expand.dots = FALSE))[-1]
+dots <- mc$"..."
+if(is.null(dots$alpha.trsp)) dots$alpha.trsp <- 100
+if(is.null(dots$with.legend)) dots$with.legend <- TRUE
+if(missing(x)) stop("Argument 'x' must be given as argument to 'plotOutlyingness'")
+if(missing(alpha)) stop("Argument 'alpha' must be given as argument to 'plotOutlyingness'")
+if(missing(fam)) stop("Argument 'fam' must be given as argument to 'plotOutlyingness'")
+##logarithmic representation (for distributions with positive support)
+fam at distribution = log(fam at distribution)
+##classical IC
+ICmle <- optIC(model=fam,risk=asCov())
+##parameter for plotting
+if(with.legend)
+{par(cex=1,bty="n", col = addAlphTrsp2col(rgb(102,102,102,maxColorValue=255), alpha.trsp),
+col.main = "black", col.lab = "black")
+col.Abline = rgb(52,52,52,maxColorValue=255)}
+else
+{par(cex=1,bty="n", col = addAlphTrsp2col(rgb(102,102,102,maxColorValue=255), alpha.trsp),
+col.main = "white", col.lab = "white")
+colAbline = "white"}
+cutoff.quantile.x = alpha
+cutoff.quantile.y = alpha
+##call of routine from RobAStBase
+outlyingPlotIC(x
+,IC.x = ICmle
+,IC.y = ICmle
+,dist.x = QProj()
+#NormType() - Euclidean norm, default - Mahalanobis norm
+#,dist.y = NormType()
+,adj = 0.1
+,pch = 21
+,col.idn = rgb(102,102,102,maxColorValue=255)
+,cex.idn = 1.7
+,col.cutoff = rgb(202,202,202,maxColorValue=255)
+,offset = 0
+,cutoff.quantile.x = cutoff.quantile.x
+,cutoff.quantile.y = cutoff.quantile.y
+,cutoff.x = cutoff()
+,cutoff.y = cutoff.sememp()
+,robCov.x = TRUE
+,robCov.y = TRUE
+,tf.x = function(x)log(x)
+,cex.main = 1.5
+,cex.lab = 1.5
+,cex = 1.5
+#,col.lab=FhGred
+,lwd.cutoff = 3
+#,jitt.fac = 300
+,col.abline = colAbline
+,cex.abline = 1.2
+,adj.abline = c(0.8, 0.2)
+,main = ""#"Outlyingness Plot"
+,xlab="Theoretical log-quantiles"
+,ylab="Mahalanobis distance"
+)
+}
+##Example
+require(RobExtremes)
+X = GPareto()
+fam = GParetoFamily()
+x = r(X)(1000)
+plotOutlyingness(x,alpha=0.95,fam=fam,alpha.trsp=75, with.legend = TRUE)
+plotOutlyingness(x,alpha=0.99,fam=fam, with.legend = FALSE)
+##########################################
+## ##
+## Wrapper for outlyingnessPlot.R ##
+## ##
+## ##
+##########################################
+##projection distance
+qfun = function(x){p0 = p(X)(x); q0 = q(X)(p0)}
+QProj <- function(){new("NormType", name="Quantiles", fct=qfun)}
+##@x - dataset
+##@X - random variable
+##@fam - parameter family
+##@alpha - confidence level for quantile
+#
+plotOutlyingness = function(x,alpha=0.99,fam=GParetoFamily(),...,alpha.trsp = 100, with.legend = TRUE){
+mc <- as.list(match.call(expand.dots = FALSE))[-1]
+dots <- mc$"..."
+if(is.null(dots$alpha.trsp)) dots$alpha.trsp <- 100
+if(is.null(dots$with.legend)) dots$with.legend <- TRUE
+if(missing(x)) stop("Argument 'x' must be given as argument to 'plotOutlyingness'")
+if(missing(alpha)) stop("Argument 'alpha' must be given as argument to 'plotOutlyingness'")
+if(missing(fam)) stop("Argument 'fam' must be given as argument to 'plotOutlyingness'")
+##logarithmic representation (for distributions with positive support)
+fam at distribution = log(fam at distribution)
+##classical IC
+ICmle <- optIC(model=fam,risk=asCov())
+##parameter for plotting
+if(with.legend)
+{par(cex=1,bty="n", col = addAlphTrsp2col(rgb(102,102,102,maxColorValue=255), alpha.trsp),
+col.main = "black", col.lab = "black")
+col.Abline = rgb(52,52,52,maxColorValue=255)}
+else
+{par(cex=1,bty="n", col = addAlphTrsp2col(rgb(102,102,102,maxColorValue=255), alpha.trsp),
+col.main = "white", col.lab = "white")
+colAbline = "white"}
+print(colAbline)
+cutoff.quantile.x = alpha
+cutoff.quantile.y = alpha
+##call of routine from RobAStBase
+outlyingPlotIC(x
+,IC.x = ICmle
+,IC.y = ICmle
+,dist.x = QProj()
+#NormType() - Euclidean norm, default - Mahalanobis norm
+#,dist.y = NormType()
+,adj = 0.1
+,pch = 21
+,col.idn = rgb(102,102,102,maxColorValue=255)
+,cex.idn = 1.7
+,col.cutoff = rgb(202,202,202,maxColorValue=255)
+,offset = 0
+,cutoff.quantile.x = cutoff.quantile.x
+,cutoff.quantile.y = cutoff.quantile.y
+,cutoff.x = cutoff()
+,cutoff.y = cutoff.sememp()
+,robCov.x = TRUE
+,robCov.y = TRUE
+,tf.x = function(x)log(x)
+,cex.main = 1.5
+,cex.lab = 1.5
+,cex = 1.5
+#,col.lab=FhGred
+,lwd.cutoff = 3
+#,jitt.fac = 300
+,col.abline = colAbline
+,cex.abline = 1.2
+,adj.abline = c(0.8, 0.2)
+,main = ""#"Outlyingness Plot"
+,xlab="Theoretical log-quantiles"
+,ylab="Mahalanobis distance"
+)
+}
+##Example
+require(RobExtremes)
+X = GPareto()
+fam = GParetoFamily()
+x = r(X)(1000)
+plotOutlyingness(x,alpha=0.95,fam=fam,alpha.trsp=75, with.legend = TRUE)
+plotOutlyingness(x,alpha=0.99,fam=fam, with.legend = FALSE)
+##########################################
+## ##
+## Wrapper for outlyingnessPlot.R ##
+## ##
+## ##
+##########################################
+##projection distance
+qfun = function(x){p0 = p(X)(x); q0 = q(X)(p0)}
+QProj <- function(){new("NormType", name="Quantiles", fct=qfun)}
+##@x - dataset
+##@X - random variable
+##@fam - parameter family
+##@alpha - confidence level for quantile
+#
+plotOutlyingness = function(x,alpha=0.99,fam=GParetoFamily(),...,alpha.trsp = 100, with.legend = TRUE){
+mc <- as.list(match.call(expand.dots = FALSE))[-1]
+dots <- mc$"..."
+if(is.null(dots$alpha.trsp)) dots$alpha.trsp <- 100
+if(is.null(dots$with.legend)) dots$with.legend <- TRUE
+if(missing(x)) stop("Argument 'x' must be given as argument to 'plotOutlyingness'")
+if(missing(alpha)) stop("Argument 'alpha' must be given as argument to 'plotOutlyingness'")
+if(missing(fam)) stop("Argument 'fam' must be given as argument to 'plotOutlyingness'")
+##logarithmic representation (for distributions with positive support)
+fam at distribution = log(fam at distribution)
+##classical IC
+ICmle <- optIC(model=fam,risk=asCov())
+##parameter for plotting
+if(with.legend)
+{par(cex=1,bty="n", col = addAlphTrsp2col(rgb(102,102,102,maxColorValue=255), alpha.trsp),
+col.main = "black", col.lab = "black")}
+else
+{par(cex=1,bty="n", col = addAlphTrsp2col(rgb(102,102,102,maxColorValue=255), alpha.trsp),
+col.main = "white", col.lab = "white")}
+cutoff.quantile.x = alpha
+cutoff.quantile.y = alpha
+##call of routine from RobAStBase
+outlyingPlotIC(x
+,IC.x = ICmle
+,IC.y = ICmle
+,dist.x = QProj()
+#NormType() - Euclidean norm, default - Mahalanobis norm
+#,dist.y = NormType()
+,adj = 0.1
+,pch = 21
+,col.idn = rgb(102,102,102,maxColorValue=255)
+,cex.idn = 1.7
+,col.cutoff = rgb(202,202,202,maxColorValue=255)
+,offset = 0
+,cutoff.quantile.x = cutoff.quantile.x
+,cutoff.quantile.y = cutoff.quantile.y
+,cutoff.x = cutoff()
+,cutoff.y = cutoff.sememp()
+,robCov.x = TRUE
+,robCov.y = TRUE
+,tf.x = function(x)log(x)
+,cex.main = 1.5
+,cex.lab = 1.5
+,cex = 1.5
+#,col.lab=FhGred
+,lwd.cutoff = 3
+#,jitt.fac = 300
+,col.abline = rgb(52,52,52,maxColorValue=255)
+,cex.abline = 1.2
+,adj.abline = c(0.8, 0.2)
+,main = ""#"Outlyingness Plot"
+,xlab="Theoretical log-quantiles"
+,ylab="Mahalanobis distance"
+)
+}
+##Example
+require(RobExtremes)
+X = GPareto()
+fam = GParetoFamily()
+x = r(X)(1000)
+plotOutlyingness(x,alpha=0.95,fam=fam,alpha.trsp=75, with.legend = TRUE)
+plotOutlyingness(x,alpha=0.99,fam=fam, with.legend = FALSE)
+##########################################
+## ##
+## Wrapper for outlyingnessPlot.R ##
+## ##
+## ##
+##########################################
+##projection distance
+qfun = function(x){p0 = p(X)(x); q0 = q(X)(p0)}
+QProj <- function(){new("NormType", name="Quantiles", fct=qfun)}
+##@x - dataset
+##@X - random variable
+##@fam - parameter family
+##@alpha - confidence level for quantile
+#
+plotOutlyingness = function(x,alpha=0.99,fam=GParetoFamily(),...,alpha.trsp = 100, with.legend = TRUE){
+mc <- as.list(match.call(expand.dots = FALSE))[-1]
+dots <- mc$"..."
+if(is.null(dots$alpha.trsp)) dots$alpha.trsp <- 100
+if(is.null(dots$with.legend)) dots$with.legend <- TRUE
+if(missing(x)) stop("Argument 'x' must be given as argument to 'plotOutlyingness'")
+if(missing(alpha)) stop("Argument 'alpha' must be given as argument to 'plotOutlyingness'")
+if(missing(fam)) stop("Argument 'fam' must be given as argument to 'plotOutlyingness'")
+##logarithmic representation (for distributions with positive support)
+fam at distribution = log(fam at distribution)
+##classical IC
+ICmle <- optIC(model=fam,risk=asCov())
+##parameter for plotting
+if(with.legend)
+{par(cex=1,bty="n", col = addAlphTrsp2col(rgb(102,102,102,maxColorValue=255), alpha.trsp),
+col.main = "black", col.lab = "black")}
+else
+{par(cex=1,bty="n", col = addAlphTrsp2col(rgb(102,102,102,maxColorValue=255), alpha.trsp),
+col.main = "white", col.lab = "white")}
+cutoff.quantile.x = alpha
+cutoff.quantile.y = alpha
+##call of routine from RobAStBase
+outlyingPlotIC(x
+,IC.x = ICmle
+,IC.y = ICmle
+,dist.x = QProj()
+#NormType() - Euclidean norm, default - Mahalanobis norm
+#,dist.y = NormType()
+,adj = 0.1
+,pch = 21
+,col.idn = rgb(102,102,102,maxColorValue=255)
+,cex.idn = 1.7
+,col.cutoff = rgb(202,202,202,maxColorValue=255)
+,offset = 0
+,cutoff.quantile.x = cutoff.quantile.x
+,cutoff.quantile.y = cutoff.quantile.y
+,cutoff.x = cutoff()
+,cutoff.y = cutoff.sememp()
+,robCov.x = TRUE
+,robCov.y = TRUE
+,tf.x = function(x)log(x)
+,cex.main = 1.5
+,cex.lab = 1.5
+,cex = 1.5
+#,col.lab=FhGred
+,lwd.cutoff = 3
+#,jitt.fac = 300
+,col.abline = rgb(52,52,52,maxColorValue=255)
+,cex.abline = 1.2
+,adj.abline = c(0.8, 0.2)
+,main = ""#"Outlyingness Plot"
+,xlab="Theoretical log-quantiles"
+,ylab="Mahalanobis distance"
+)
+}
+##Example
+require(RobExtremes)
+X = GPareto()
+fam = GParetoFamily()
+x = r(X)(1000)
+plotOutlyingness(x,alpha=0.95,fam=fam,alpha.trsp=50, with.legend = TRUE)
+plotOutlyingness(x,alpha=0.99,fam=fam, with.legend = FALSE)
+myplot <- function(x,y, ..., withCall =TRUE){
+###
+### 1. grab the dots (and probably manipulate it within the wrapper function)
+###
+dots <- as.list(match.call(expand.dots=FALSE))$"..."
+###
+## 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")
+###
+### 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,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(withCall) return(mycall) else return(invisible(NULL))
+}
+x <- 1:20
+y <- rnorm(20)
+cl <- myplot(x,y,col="red")
+eval(cl)
+cl <- myplot(x,y)
+args <- c(list(x=substitute(x),y=substitute(y)),dots, type="l")
+dots <- as.list(match.call(expand.dots=FALSE))$"..."
+cl <- substitute(do.call(plot,args0), list(args0=args))
+cl0 <- as.list(cl)[-1]
+mycall <- c(cl0,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(withCall) return(mycall) else return(invisible(NULL))
+##########################################
+## ##
+## Wrapper for outlyingnessPlot.R ##
+## ##
+## ##
+##########################################
+##projection distance
+qfun = function(x){p0 = p(X)(x); q0 = q(X)(p0)}
+QProj <- function(){new("NormType", name="Quantiles", fct=qfun)}
+##@x - dataset
+##@X - random variable
+##@fam - parameter family
+##@alpha - confidence level for quantile
+#
+plotOutlyingness = function(x,alpha=0.99,fam=GParetoFamily(),...,alpha.trsp = 100, with.legend = TRUE){
+mc <- as.list(match.call(expand.dots = FALSE))[-1]
+dots <- mc$"..."
+if(is.null(dots$alpha.trsp)) dots$alpha.trsp <- 100
+if(is.null(dots$with.legend)) dots$with.legend <- TRUE
+if(missing(x)) stop("Argument 'x' must be given as argument to 'plotOutlyingness'")
+if(missing(alpha)) stop("Argument 'alpha' must be given as argument to 'plotOutlyingness'")
+if(missing(fam)) stop("Argument 'fam' must be given as argument to 'plotOutlyingness'")
+args <- c(list(x=substitute(x),alpha=substitute(alpha),fam=substitute(fam)),dots, type="l")
+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,unlist(cl0[-1]))
+mycall <- as.call(mycall)
+###
+### 4. evaluate the call (i.e., produce the graphic)
+###
+eval(mycall)
+##logarithmic representation (for distributions with positive support)
+fam at distribution = log(fam at distribution)
+##classical IC
+ICmle <- optIC(model=fam,risk=asCov())
+##parameter for plotting
+if(with.legend)
+{par(cex=1,bty="n", col = addAlphTrsp2col(rgb(102,102,102,maxColorValue=255), alpha.trsp),
+col.main = "black", col.lab = "black")}
+else
+{par(cex=1,bty="n", col = addAlphTrsp2col(rgb(102,102,102,maxColorValue=255), alpha.trsp),
+col.main = "white", col.lab = "white")}
+cutoff.quantile.x = alpha
+cutoff.quantile.y = alpha
+##call of routine from RobAStBase
+outlyingPlotIC(x
+,IC.x = ICmle
+,IC.y = ICmle
+,dist.x = QProj()
+#NormType() - Euclidean norm, default - Mahalanobis norm
+#,dist.y = NormType()
+,adj = 0.1
+,pch = 21
+,col.idn = rgb(102,102,102,maxColorValue=255)
+,cex.idn = 1.7
+,col.cutoff = rgb(202,202,202,maxColorValue=255)
+,offset = 0
+,cutoff.quantile.x = cutoff.quantile.x
+,cutoff.quantile.y = cutoff.quantile.y
+,cutoff.x = cutoff()
+,cutoff.y = cutoff.sememp()
+,robCov.x = TRUE
+,robCov.y = TRUE
+,tf.x = function(x)log(x)
+,cex.main = 1.5
+,cex.lab = 1.5
+,cex = 1.5
+#,col.lab=FhGred
+,lwd.cutoff = 3
+#,jitt.fac = 300
+,col.abline = rgb(52,52,52,maxColorValue=255)
+,cex.abline = 1.2
+,adj.abline = c(0.8, 0.2)
+,main = ""#"Outlyingness Plot"
+,xlab="Theoretical log-quantiles"
+,ylab="Mahalanobis distance"
+)
+}
+##Example
+require(RobExtremes)
+X = GPareto()
+fam = GParetoFamily()
+x = r(X)(1000)
+plotOutlyingness(x,alpha=0.95,fam=fam,alpha.trsp=50, with.legend = TRUE)
+plotOutlyingness(x,alpha=0.99,fam=fam, with.legend = FALSE)
+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")
+###
+### 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)
+}
+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)
Added: branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/HelpFunction.R
===================================================================
--- branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/HelpFunction.R (rev 0)
+++ branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/HelpFunction.R 2013-05-31 07:23:55 UTC (rev 667)
@@ -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.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper.R
===================================================================
--- branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper.R (rev 0)
+++ branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper.R 2013-05-31 07:23:55 UTC (rev 667)
@@ -0,0 +1,172 @@
+##########################################
+## ##
+## Wrapper for AllPlot.R ##
+## (plot method for IC) ##
+## ##
+##########################################
+
+##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, 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$alpha.trsp)) alpha.trsp <- 100
+ if(is.null(mc$with.legend)) mc$with.legend <- TRUE
+ if(is.null(mc$withCall)) mc$withCall <- TRUE
+ if(missing(IC)) stop("Argument 'IC' must be given as argument to 'ICAllPlotWrapper'")
+ ###
+ ### 2. build up the argument list for the (powerful/fullfledged)
+ ### graphics/diagnostics function;
+ ##
+
+ if(missing(y)){
+ argsList <- 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)
+ ,scaleX = substitute(FALSE)
+ ,scaleX.fct = substitute(p(eval(IC at CallL2Fam)))
+ ,scaleX.inv = substitute(q(eval(IC at CallL2Fam)))
+ ,scaleY = substitute(FALSE)
+ ,scaleY.fct = substitute(pnorm)
+ ,scaleY.inv=substitute(qnorm)
+ ,scaleN = substitute(9)
+ ,x.ticks = substitute(NULL)
+ ,y.ticks = substitute(NULL)
+ ,mfColRow = substitute(TRUE)
+ ,to.draw.arg = substitute(NULL)
+ ,adj = substitute(0.1)
+ ,cex.main = substitute(1.5)
+ ,cex.lab = substitute(1.5)
+ ,cex = substitute(1.5)
+ ,bty = substitute("n")
+ ,panel.first= substitute(grid())
+ ,col = substitute("blue")
+ )
+ }else{
+ argsList <- 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)
+ ,adj = substitute(0.1)
+ ,cex.main = substitute(1.5)
+ ,cex.lab = substitute(1.5)
+ ,cex = substitute(1.5)
+ ,bty = substitute("n")
+ ,panel.first= substitute(grid())
+ ,col = substitute("blue")
+ )
+ }
+
+
+
+ ##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 <- c(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, alpha.trsp=50, with.legend = FALSE)
+dev.new()
+ICAllPlotWrapper(IC, y, alpha.trsp=50, with.legend = FALSE)
+
+# GEV
+fam = GEVFamily()
+IC <- optIC(model = fam, risk = asCov())
+Y=distribution(fam)
+y = r(Y)(1000)
+dev.new()
+ICAllPlotWrapper(IC, with.legend = TRUE, withCall = TRUE)
+dev.new()
+ICAllPlotWrapper(IC, y, with.legend = TRUE, withCall = TRUE)
+
+# Gamma
+fam = GammaFamily()
+IC <- optIC(model = fam, risk = asCov())
+Y=distribution(fam)
+y = r(Y)(1000)
+dev.new()
+ICAllPlotWrapper(IC, alpha.trsp=70)
+dev.new()
+ICAllPlotWrapper(IC, y, alpha.trsp=70)
+
+# Weibull
+fam = WeibullFamily()
+IC <- optIC(model = fam, risk = asCov())
+Y=distribution(fam)
+y = r(Y)(1000)
+dev.new()
+ICAllPlotWrapper(IC, alpha.trsp=50, with.legend = TRUE, withCall = FALSE)
+dev.new()
+ICAllPlotWrapper(IC, y, alpha.trsp=50, with.legend = TRUE, withCall = FALSE)
+
Added: branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GEV_LegendTrue.jpeg
===================================================================
(Binary files differ)
Property changes on: branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GEV_LegendTrue.jpeg
___________________________________________________________________
Added: svn:mime-type
+ application/octet-stream
Added: branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GEV_data_LegendTrue.jpeg
===================================================================
(Binary files differ)
Property changes on: branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GEV_data_LegendTrue.jpeg
___________________________________________________________________
Added: svn:mime-type
+ application/octet-stream
Added: branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GPD_Trsp50_LegendFalse.jpeg
===================================================================
(Binary files differ)
Property changes on: branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GPD_Trsp50_LegendFalse.jpeg
___________________________________________________________________
Added: svn:mime-type
+ application/octet-stream
Added: branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GPD_data_Trsp50_LegendFalse.jpeg
===================================================================
(Binary files differ)
Property changes on: branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_GPD_data_Trsp50_LegendFalse.jpeg
___________________________________________________________________
Added: svn:mime-type
+ application/octet-stream
Added: branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Gamma_Trsp70.jpeg
===================================================================
(Binary files differ)
Property changes on: branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Gamma_Trsp70.jpeg
___________________________________________________________________
Added: svn:mime-type
+ application/octet-stream
Added: branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Gamma_data_Trsp70.jpeg
===================================================================
(Binary files differ)
Property changes on: branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Gamma_data_Trsp70.jpeg
___________________________________________________________________
Added: svn:mime-type
+ application/octet-stream
Added: branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Weibull_Trsp50_LegendTrue.jpeg
===================================================================
(Binary files differ)
Property changes on: branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Weibull_Trsp50_LegendTrue.jpeg
___________________________________________________________________
Added: svn:mime-type
+ application/octet-stream
Added: branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Weibull_data_Trsp50_LegendTrue.jpeg
===================================================================
(Binary files differ)
Property changes on: branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/ICAllPlotWrapper_Weibull_data_Trsp50_LegendTrue.jpeg
___________________________________________________________________
Added: svn:mime-type
+ application/octet-stream
Added: branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/cniperCont.R
===================================================================
--- branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/cniperCont.R (rev 0)
+++ branches/robast-0.9/pkg/13.05.31 - Wrapper for RobAStBase, RobExtremes/cniperCont.R 2013-05-31 07:23:55 UTC (rev 667)
@@ -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){
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/robast -r 667
More information about the Robast-commits
mailing list