[Distr-commits] r1208 - branches/distr-2.8/pkg/distrMod/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sun Jul 22 01:05:06 CEST 2018
Author: ruckdeschel
Date: 2018-07-22 01:05:03 +0200 (Sun, 22 Jul 2018)
New Revision: 1208
Modified:
branches/distr-2.8/pkg/distrMod/R/qqplot.R
branches/distr-2.8/pkg/distrMod/R/returnlevelplot.R
Log:
[distrMod] branch 2.8 unified return values / plotInfo values for qqplot and returnlevelplot
Modified: branches/distr-2.8/pkg/distrMod/R/qqplot.R
===================================================================
--- branches/distr-2.8/pkg/distrMod/R/qqplot.R 2018-07-20 14:36:26 UTC (rev 1207)
+++ branches/distr-2.8/pkg/distrMod/R/qqplot.R 2018-07-21 23:05:03 UTC (rev 1208)
@@ -318,6 +318,7 @@
withConf.pw = if(!missing(withConf.pw)) withConf.pw else if(!missing(withConf)) withConf else NULL,
withConf.sim = if(!missing(withConf.sim)) withConf.sim else if(!missing(withConf)) withConf else NULL,
plot.it = plot.it, xlab = xlab, ylab = ylab)
+ plotInfo <- list(call=mc, dots=dots, args=args0)
if(missing(xlab)) mc$xlab <- as.character(deparse(mc$x))
if(missing(ylab)) mc$ylab <- as.character(deparse(mc$y))
@@ -329,10 +330,10 @@
retv <- do.call(getMethod("qqplot", signature(x="ANY", y="UnivariateDistribution")),
args=mcl)
- retv$call <- mc
- retv$args <- args0
- retv$dots <- dots
- return(invisible(retv))
+ retv$call <- retv$dots <- retv$args <- NULL
+ plotInfo <- c(plotInfo,retv)
+ class(plotInfo) <- c("qqplotInfo","DiagnInfo")
+ return(invisible(plotInfo))
})
setMethod("qqplot", signature(x = "ANY",
@@ -342,15 +343,15 @@
plot.it = TRUE, xlab = deparse(substitute(x)),
ylab = deparse(substitute(y)), ...){
+ args0 <- list(x=x,y=y,n=n,withIdLine=withIdLine, withConf=withConf,
+ withConf.pw = if(!missing(withConf.pw)) withConf.pw else if(!missing(withConf)) withConf else NULL,
+ withConf.sim = if(!missing(withConf.sim)) withConf.sim else if(!missing(withConf)) withConf else NULL,
+ plot.it = plot.it, xlab = xlab, ylab = ylab)
+
mc <- match.call(call = sys.call(sys.parent(1)))
- dots <- match.call(call = sys.call(sys.parent(1)),
- expand.dots = FALSE)$"..."
- args0 <- list(x = x, y = y,
- n = if(!missing(n)) n else length(x),
- withIdLine = withIdLine, withConf = withConf,
- withConf.pw = if(!missing(withConf.pw)) withConf.pw else if(!missing(withConf)) withConf else NULL,
- withConf.sim = if(!missing(withConf.sim)) withConf.sim else if(!missing(withConf)) withConf else NULL,
- plot.it = plot.it, xlab = xlab, ylab = ylab)
+ mc1 <- match.call(call = sys.call(sys.parent(1)), expand.dots=FALSE)
+ dots <- mc1$"..."
+ plotInfo <- list(call=mc, dots=dots, args=args0)
if(missing(xlab)) mc$xlab <- as.character(deparse(mc$x))
if(missing(ylab)) mc$ylab <- as.character(deparse(mc$y))
@@ -371,9 +372,9 @@
mcl$y <- PFam0
retv <- do.call(getMethod("qqplot", signature(x="ANY", y="ProbFamily")),
args=mcl)
- retv$call <- mc
- retv$args <- args0
- retv$dots <- dots
- return(invisible(retv))
+ retv$call <- retv$dots <- retv$args <- NULL
+ plotInfo <- c(plotInfo,retv)
+ class(plotInfo) <- c("qqplotInfo","DiagnInfo")
+ return(invisible(plotInfo))
})
Modified: branches/distr-2.8/pkg/distrMod/R/returnlevelplot.R
===================================================================
--- branches/distr-2.8/pkg/distrMod/R/returnlevelplot.R 2018-07-20 14:36:26 UTC (rev 1207)
+++ branches/distr-2.8/pkg/distrMod/R/returnlevelplot.R 2018-07-21 23:05:03 UTC (rev 1208)
@@ -71,9 +71,34 @@
debug = FALSE, ## shall additional debug output be printed out?
withSubst = TRUE
){ ## return value as in stats::qqplot
+ args0 <- list(x = x, y = y, n = n, withIdLine = withIdLine,
+ withConf = withConf, withConf.pw = withConf.pw,
+ withConf.sim = withConf.sim, plot.it = plot.it, datax = datax,
+ xlab = xlab, ylab = ylab, width = width, height = height,
+ withSweave = withSweave, mfColRow = mfColRow,
+ n.CI = n.CI, withLab = withLab, lab.pts = lab.pts,
+ which.lbs = which.lbs, which.Order = which.Order,
+ order.traf = order.traf, col.IdL = col.IdL, lty.IdL = lty.IdL,
+ lwd.IdL = lwd.IdL, alpha.CI = alpha.CI, exact.pCI = exact.pCI,
+ exact.sCI = exact.sCI, nosym.pCI = nosym.pCI, col.pCI = col.pCI,
+ lty.pCI = lty.pCI, lwd.pCI = lwd.pCI, pch.pCI = pch.pCI,
+ cex.pCI = cex.pCI, col.sCI = col.sCI, lty.sCI = lty.sCI,
+ lwd.sCI = lwd.sCI, pch.sCI = pch.sCI, cex.sCI = cex.sCI,
+ added.points.CI = added.points.CI, cex.pch = cex.pch,
+ col.pch = col.pch, cex.lbl = cex.lbl, col.lbl = col.lbl,
+ adj.lbl = adj.lbl, alpha.trsp = alpha.trsp, jit.fac = jit.fac,
+ jit.tol = jit.tol, check.NotInSupport = check.NotInSupport,
+ col.NotInSupport = col.NotInSupport, with.legend = with.legend,
+ legend.bg = legend.bg, legend.pos = legend.pos,
+ legend.cex = legend.cex, legend.pref = legend.pref,
+ legend.postf = legend.postf, legend.alpha = legend.alpha,
+ debug = debug, withSubst = withSubst)
+ mc <- match.call(call = sys.call(sys.parent(1)))
+ dots <- match.call(call = sys.call(sys.parent(1)),
+ expand.dots = FALSE)$"..."
+ plotInfo <- list(call = mc, dots=dots, args=args0)
MaxOrPOT <- match.arg(MaxOrPOT)
- mc <- match.call(call = sys.call(sys.parent(1)))
xcc <- as.character(deparse(mc$x))
.mpresubs <- if(withSubst){
@@ -201,15 +226,18 @@
if(datax){
mcl$xlab <- xlab
mcl$ylab <- ylab
- do.call(plot, c(list(x=xallc1, y=yallc1, log="y",type="n"),mcl))
- do.call(points, c(list(x=xj, y=ycl), mcl))
+ plotInfo$plotArgs <- c(list(x=xallc1, y=yallc1, log="y",type="n"),mcl)
+ plotInfo$pointArgs <- c(list(x=xj, y=ycl), mcl)
# ret <- do.call(stats::qqplot, args=mcl0, log="y", ylim = c(0.1,1000))
}else{
mcl$ylab <- xlab
mcl$xlab <- ylab
- do.call(plot, c(list(x=yallc1, y=xallc1, log="x",type="n"),mcl))
- do.call(points, c(list(x=ycl, y=xj),mcl))
+ plotInfo$plotArgs <- c(list(x=yallc1, y=xallc1, log="x",type="n"),mcl)
+ plotInfo$pointArgs <- c(list(x=ycl, y=xj), mcl)
}
+ do.call(plot, plotInfo$plotArgs)
+ plotInfo$usr <- par("usr")
+ do.call(points, plotInfo$pointArgs)
}
if(withLab&& plot.it){
@@ -218,6 +246,8 @@
lbprep$y0 <- p2rl(lbprep$y0)
xlb0 <- if(datax) lbprep$x0 else lbprep$y0
ylb0 <- if(datax) lbprep$y0 else lbprep$x0
+ plotInfo$textArgs <- list(x = xlb0, y = ylb0, labels = lbprep$lab,
+ cex = lbprep$cex, col = lbprep$col, adj = adj.lbl)
text(x = xlb0, y = ylb0, labels = lbprep$lab,
cex = lbprep$cex, col = lbprep$col, adj = adj.lbl)
}
@@ -225,10 +255,13 @@
if(withIdLine){
if(plot.it){
if(datax){
+ plotInfo$IdLineArgs <- list(xyallc,pxyallc,col=col.IdL,lty=lty.IdL,lwd=lwd.IdL)
lines(xyallc,pxyallc,col=col.IdL,lty=lty.IdL,lwd=lwd.IdL)
}else{
+ plotInfo$IdLineArgs <- list(pxyallc,xyallc,col=col.IdL,lty=lty.IdL,lwd=lwd.IdL)
lines(pxyallc,xyallc,col=col.IdL,lty=lty.IdL,lwd=lwd.IdL)
}
+
}
qqb <- NULL
if(#is(y,"AbscontDistribution")&&
@@ -273,7 +306,9 @@
qqb0=NULL, transf0=p2rl, debug = debug)
}
}}
- return(invisible(c(ret,qqb)))
+ plotInfo <- c(plotInfo, ret=ret,qqb=qqb)
+ class(plotInfo) <- c("plotInfo","DiagnInfo")
+ return(invisible(plotInfo))
})
## into distrMod
@@ -285,6 +320,17 @@
ylab = deparse(substitute(y)), ...){
mc <- match.call(call = sys.call(sys.parent(1)))
+ dots <- match.call(call = sys.call(sys.parent(1)),
+ expand.dots = FALSE)$"..."
+ args0 <- list(x = x, y = y,
+ n = if(!missing(n)) n else length(x),
+ withIdLine = withIdLine, withConf = withConf,
+ withConf.pw = if(!missing(withConf.pw)) withConf.pw else if(!missing(withConf)) withConf else NULL,
+ withConf.sim = if(!missing(withConf.sim)) withConf.sim else if(!missing(withConf)) withConf else NULL,
+ plot.it = plot.it, xlab = xlab, ylab = ylab)
+
+ plotInfo <- list(call=mc, dots=dots, args=args0)
+
if(missing(xlab)) mc$xlab <- paste(gettext("Return Level of"), as.character(deparse(mc$x)))
if(missing(ylab)) mc$ylab <- paste(gettext("Return Period at"), as.character(deparse(mc$y)))
mcl <- as.list(mc)[-1]
@@ -293,8 +339,12 @@
if(!is(yD,"UnivariateDistribution"))
stop("Not yet implemented.")
- return(invisible(do.call(getMethod("returnlevelplot", signature(x="ANY", y="UnivariateDistribution")),
- args=mcl)))
+ retv <- do.call(getMethod("returnlevelplot", signature(x="ANY", y="UnivariateDistribution")),
+ args=mcl)
+ retv$call <- retv$dots <- retv$args <- NULL
+ plotInfo <- c(plotInfo,retv)
+ class(plotInfo) <- c("plotInfo","DiagnInfo")
+ return(invisible(plotInfo))
})
setMethod("returnlevelplot", signature(x = "ANY",
@@ -305,6 +355,15 @@
ylab = deparse(substitute(y)), ...){
mc <- match.call(call = sys.call(sys.parent(1)))
+ dots <- match.call(call = sys.call(sys.parent(1)),
+ expand.dots = FALSE)$"..."
+ args0 <- list(x = x, y = y,
+ n = if(!missing(n)) n else length(x),
+ withIdLine = withIdLine, withConf = withConf,
+ withConf.pw = if(!missing(withConf.pw)) withConf.pw else if(!missing(withConf)) withConf else NULL,
+ withConf.sim = if(!missing(withConf.sim)) withConf.sim else if(!missing(withConf)) withConf else NULL,
+ plot.it = plot.it, xlab = xlab, ylab = ylab)
+
if(missing(xlab)) mc$xlab <- paste(gettext("Return Level of"), as.character(deparse(mc$x)))
mcl <- as.list(mc)[-1]
@@ -323,6 +382,10 @@
mcl$y <- PFam0
if(missing(ylab)) mc$ylab <- paste(gettext("Return Period at fitted"), name(PFam0))
- return(invisible(do.call(getMethod("returnlevelplot", signature(x="ANY", y="ProbFamily")),
- args=mcl)))
+ retv <- do.call(getMethod("returnlevelplot", signature(x="ANY", y="ProbFamily")),
+ args=mcl)
+ retv$call <- retv$dots <- retv$args <- NULL
+ plotInfo <- c(plotInfo,retv)
+ class(plotInfo) <- c("plotInfo","DiagnInfo")
+ return(invisible(plotInfo))
})
More information about the Distr-commits
mailing list