[Robast-commits] r979 - branches/robast-1.1/pkg/RobExtremes/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Jul 18 18:08:58 CEST 2018
Author: ruckdeschel
Date: 2018-07-18 18:08:58 +0200 (Wed, 18 Jul 2018)
New Revision: 979
Modified:
branches/robast-1.1/pkg/RobExtremes/R/plotOutlyingness.R
Log:
[RobExtremes] branch 1.1 updated/prepared plotOutlyingness.R
Modified: branches/robast-1.1/pkg/RobExtremes/R/plotOutlyingness.R
===================================================================
--- branches/robast-1.1/pkg/RobExtremes/R/plotOutlyingness.R 2018-07-18 16:06:25 UTC (rev 978)
+++ branches/robast-1.1/pkg/RobExtremes/R/plotOutlyingness.R 2018-07-18 16:08:58 UTC (rev 979)
@@ -6,17 +6,87 @@
##########################################
if(FALSE){
-##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,X=GPareto(),fam=GParetoFamily()){
+plotOutlyingness = function(x,alpha=0.99,X=GPareto(),fam=GParetoFamily(),
+ dist.y = NormType(),
+ cutoff.x = cutoff(), cutoff.y = cutoff.sememp(),
+ ...,
+ id.n,
+ cex.pts = 1,
+ lab.pts,
+ jitter.pts = 0,
+ alpha.trsp = NA,
+ adj = 0.1,
+ pch = 16,
+ cex = 1.5,
+ col = rgb(152,152,152,maxColorValue=255),
+ cex.idn = 1.7,
+ col.idn = rgb(102,102,102,maxColorValue=255),
+ lty.cutoff,
+ lwd.cutoff = 3,
+ col.cutoff = rgb(202,202,202,maxColorValue=255),
+ text.abline = TRUE,
+ text.abline.x = NULL, text.abline.y = NULL,
+ cex.abline = par("cex"), col.abline = col.cutoff,
+ font.abline = par("font"), adj.abline = c(0,0),
+ text.abline.x.x = NULL, text.abline.x.y = NULL,
+ text.abline.y.x = NULL, text.abline.y.y = NULL,
+ text.abline.x.fmt.cx = "%7.2f",
+ text.abline.x.fmt.qx = "%4.2f%%",
+ text.abline.y.fmt.cy = "%7.2f",
+ text.abline.y.fmt.qy = "%4.2f%%",
+ robCov.x = TRUE,
+ robCov.y = TRUE,
+ tf.x = function(x)apply(x,2,log),
+ tf.y = function(x)x[1,],
+ jitter.fac = 10,
+ jitter.tol=.Machine$double.eps,
+ cex.lab = 1.5,
+ col.lab="red",
+ main = "Outlyingness Plot for Extreme Value Distributions",
+ cex.main = 1.5,
+ xlab="Theoretical log-quantiles",
+ ylab="Mahalanobis distance",
+ doplot = TRUE
+ ){
+
+ mc <- match.call()
+ dots <- match.call(expand.dots = FALSE)$"..."
+ args0 <- list(x = x, alpha = alpha, X = X, fam = fam, dist.y = dist.y,
+ cutoff.x = cutoff.x, cutoff.y = cutoff.y,
+ id.n = if(missing(id.n)) NULL else id.n,
+ cex.pts = cex.pts, lab.pts = if(missing(lab.pts)) NULL else lab.pts,
+ jitter.pts = jitter.pts, alpha.trsp = alpha.trsp, adj = adj,
+ pch = pch, cex = cex, col = col, cex.idn = cex.idn, col.idn = col.idn,
+ lty.cutoff = if(missing(lty.cutoff)) NULL else lty.cutoff,
+ lwd.cutoff = lwd.cutoff, col.cutoff = col.cutoff,
+ text.abline = text.abline, text.abline.x = text.abline.x,
+ text.abline.y = text.abline.y, cex.abline = cex.abline,
+ col.abline = if(missing(col.abline)) col.cutoff else col.abline,
+ font.abline = font.abline, adj.abline = adj.abline,
+ text.abline.x.x = text.abline.x.x, text.abline.x.y = text.abline.x.y,
+ text.abline.y.x = text.abline.y.x, text.abline.y.y = text.abline.y.y,
+ text.abline.x.fmt.cx = text.abline.x.fmt.cx,
+ text.abline.x.fmt.qx = text.abline.x.fmt.qx,
+ text.abline.y.fmt.cy = text.abline.y.fmt.cy,
+ text.abline.y.fmt.qy = text.abline.y.fmt.qy, robCov.x = robCov.x,
+ robCov.y = robCov.y, tf.x = tf.x, tf.y = tf.y,
+ jitter.fac = jitter.fac, jitter.tol = jitter.tol, cex.lab = cex.lab,
+ col.lab = col.lab, main = main, cex.main = cex.main, xlab = xlab,
+ ylab = ylab, doplot = doplot)
+ plotInfo <- list(call = mc, dots=dots, args=args0)
+
+
+ ##projection distance
+ qfun = function(x){p0 = p(X)(x); q0 = q.l(X)(p0)}
+ QProj <- function(){new("NormType", name="Quantiles", fct=qfun)}
+
##logarithmic representation (for distributions with positive support)
fam at distribution = log(fam at distribution)
@@ -26,39 +96,34 @@
##parameter for plotting
par(cex=1,bty="n")
-##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 = 16
- ,col = rgb(152,152,152,maxColorValue=255)
- ,col.idn = rgb(102,102,102,maxColorValue=255)
- ,cex.idn = 1.7
- ,col.cutoff = rgb(202,202,202,maxColorValue=255)
- ,offset = 0
- ,cutoff.quantile.y = 0.99
- ,cutoff.quantile.x = 0.99
- ,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(102,102,102,maxColorValue=255)
- ,cex.abline = 1.5
- ,main = ""#"Outlyingness Plot"
- ,xlab="Theoretical log-quantiles"
- ,ylab="Mahalanobis distance"
-)
+ ##call of routine from RobAStBase
+ plotInfo$outlyingPlotICArgs <- c(list(data = x, IC.x = ICmle, IC.y = ICmle,
+ dist.x = QProj(), dist.y = dist.y, cutoff.x = cutoff.x, cutoff.y = cutoff.y),
+ dots,list(cutoff.quantile.y = cutoff.quantile.x,
+ cutoff.quantile.x = cutoff.quantile.y, id.n = id.n, cex.pts = cex.pts,
+ lab.pts = lab.pts, jitter.pts = jitter.pts, alpha.trsp = alpha.trsp,
+ adj = adj, pch = pch, cex = cex, col = col, cex.idn = cex.idn,
+ col.idn = col.idn, lty.cutoff = lty.cutoff, lwd.cutoff = lwd.cutoff,
+ col.cutoff = col.cutoff, text.abline = text.abline,
+ text.abline.x = text.abline.x, text.abline.y = text.abline.y,
+ cex.abline = cex.abline, col.abline = col.abline,
+ font.abline = font.abline, adj.abline = adj.abline,
+ text.abline.x.x = text.abline.x.x, text.abline.x.y = text.abline.x.y,
+ text.abline.y.x = text.abline.y.x, text.abline.y.y = text.abline.y.y,
+ text.abline.x.fmt.cx = text.abline.x.fmt.cx,
+ text.abline.x.fmt.qx = text.abline.x.fmt.qx,
+ text.abline.y.fmt.cy = text.abline.y.fmt.cy,
+ text.abline.y.fmt.qy = text.abline.y.fmt.qy, robCov.x = robCov.x,
+ robCov.y = robCov.y, tf.x = tf.x, tf.y = tf.y, jitter.fac = jitter.fac,
+ jitter.tol = jitter.tol, cex.lab = cex.lab, col.lab = col.lab,
+ main = main, cex.main = cex.main, xlab = xlab, ylab = ylab, doplot = doplot))
+retV <- do.call(outlyingPlotIC,args=plotInfo$outlyingPlotICArgs)
+retV$args <- NULL
+retV$dots <- NULL
+retV$call <- NULL
+plotInfo <- c(PlotInfo, retV)
+class(plotInfo) <- c("plotInfo","DiagnInfo")
+return(invisible(plotInfo))
}
##Example
More information about the Robast-commits
mailing list