From noreply at r-forge.r-project.org Fri Jun 27 00:18:29 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 27 Jun 2014 00:18:29 +0200 (CEST) Subject: [Distr-commits] r936 - in branches/distr-2.6/pkg: distr distr/R distr/man distrMod distrMod/R distrMod/man Message-ID: <20140626221829.3C0E51861AB@r-forge.r-project.org> Author: ruckdeschel Date: 2014-06-27 00:18:28 +0200 (Fri, 27 Jun 2014) New Revision: 936 Added: branches/distr-2.6/pkg/distrMod/R/returnlevelplot.R branches/distr-2.6/pkg/distrMod/man/returnlevelplot.Rd Modified: branches/distr-2.6/pkg/distr/DESCRIPTION branches/distr-2.6/pkg/distr/R/internals-qqplot.R branches/distr-2.6/pkg/distr/R/qqplot.R branches/distr-2.6/pkg/distr/man/internals-qqplot.Rd branches/distr-2.6/pkg/distr/man/qqplot.Rd branches/distr-2.6/pkg/distrMod/NAMESPACE branches/distr-2.6/pkg/distrMod/R/AllGeneric.R branches/distr-2.6/pkg/distrMod/R/qqplot.R branches/distr-2.6/pkg/distrMod/man/qqplot.Rd Log: distrMod: introduced returnlevelplot.R distr: some minor changes in qqplot Modified: branches/distr-2.6/pkg/distr/DESCRIPTION =================================================================== --- branches/distr-2.6/pkg/distr/DESCRIPTION 2014-05-15 12:55:05 UTC (rev 935) +++ branches/distr-2.6/pkg/distr/DESCRIPTION 2014-06-26 22:18:28 UTC (rev 936) @@ -3,11 +3,12 @@ Date: 2013-09-13 Title: Object oriented implementation of distributions Description: S4 Classes and Methods for distributions -Authors at R: c(person("Florian", "Camphausen", role=c("aut")), person("Matthias", "Kohl", - role=c("aut", "cph")), person("Peter", "Ruckdeschel", role=c("cre", "cph"), - email="Peter.Ruckdeschel at itwm.fraunhofer.de"), person("Thomas", "Stabla", role=c("aut", - "cph")), person("R Core Team", role = c("ctb", "cph"), comment="for source file ks.c/ - routines 'pKS2' and 'pKolmogorov2x'")) +Authors at R: c(person("Florian", "Camphausen", role=c("aut")), + person("Matthias", "Kohl", role=c("aut", "cph")), + person("Peter", "Ruckdeschel", role=c("cre", "cph"), email="Peter.Ruckdeschel at itwm.fraunhofer.de"), + person("Thomas", "Stabla", role=c("aut", "cph")), + person("R Core Team", role = c("ctb", "cph"), + comment="for source file ks.c/ routines 'pKS2' and 'pKolmogorov2x'")) Depends: R(>= 2.14.0), methods, graphics, startupmsg, sfsmisc, SweaveListingUtils Suggests: distrEx, svUnit (>= 0.7-11) Imports: stats Modified: branches/distr-2.6/pkg/distr/R/internals-qqplot.R =================================================================== --- branches/distr-2.6/pkg/distr/R/internals-qqplot.R 2014-05-15 12:55:05 UTC (rev 935) +++ branches/distr-2.6/pkg/distr/R/internals-qqplot.R 2014-06-26 22:18:28 UTC (rev 936) @@ -205,14 +205,15 @@ -.confqq <- function(x,D, withConf.pw = TRUE, withConf.sim = TRUE, alpha, +.confqq <- function(x,D, datax = TRUE, withConf.pw = TRUE, + withConf.sim = TRUE, alpha, col.pCI, lty.pCI, lwd.pCI, pch.pCI, cex.pCI, col.sCI, lty.sCI, lwd.sCI, pch.sCI, cex.sCI, n,exact.sCI=(n<100),exact.pCI=(n<100), nosym.pCI = FALSE, with.legend = TRUE, legend.bg = "white", legend.pos = "topleft", legend.cex = 0.8, legend.pref = "", legend.postf = "", - legend.alpha = alpha){ + legend.alpha = alpha, qqb0=NULL){ x <- sort(unique(x)) if("gaps" %in% names(getSlots(class(D)))) @@ -229,36 +230,65 @@ x.d <- x.in[!SI.c] - qqb <- qqbounds(x,D,alpha,n,withConf.pw, withConf.sim, - exact.sCI,exact.pCI,nosym.pCI) + qqb <- if(is.null(qqb0)) qqbounds(x,D,alpha,n,withConf.pw, withConf.sim, + exact.sCI,exact.pCI,nosym.pCI) else qqb0 + qqb$crit <- qqb$crit[SI.in,] if(qqb$err["pw"]){ if(sum(SI.c)>0){ - lines(x.c, qqb$crit[SI.c,"pw.right"], - col=col.pCI,lty=lty.pCI,lwd=lwd.pCI) - lines(x.c, qqb$crit[SI.c,"pw.left"], - col=col.pCI,lty=lty.pCI,lwd=lwd.pCI) + if(datax){ + lines(x.c, qqb$crit[SI.c,"pw.right"], + col=col.pCI,lty=lty.pCI,lwd=lwd.pCI) + lines(x.c, qqb$crit[SI.c,"pw.left"], + col=col.pCI,lty=lty.pCI,lwd=lwd.pCI) + }else{ + lines(qqb$crit[SI.c,"pw.right"], x.c, + col=col.pCI,lty=lty.pCI,lwd=lwd.pCI) + lines(qqb$crit[SI.c,"pw.left"], x.c, + col=col.pCI,lty=lty.pCI,lwd=lwd.pCI) + } } if(sum(!SI.c)>0){ - points(x.d, qqb$crit[!SI.c,"pw.right"], - col=col.pCI, pch=pch.pCI, cex = cex.pCI) - points(x.d, qqb$crit[!SI.c,"pw.left"], - col=col.pCI, pch=pch.pCI, cex = cex.pCI) + if(datax){ + points(x.d, qqb$crit[!SI.c,"pw.right"], + col=col.pCI, pch=pch.pCI, cex = cex.pCI) + points(x.d, qqb$crit[!SI.c,"pw.left"], + col=col.pCI, pch=pch.pCI, cex = cex.pCI) + }else{ + points(qqb$crit[!SI.c,"pw.right"], x.d, + col=col.pCI, pch=pch.pCI, cex = cex.pCI) + points(qqb$crit[!SI.c,"pw.left"], x.d, + col=col.pCI, pch=pch.pCI, cex = cex.pCI) + } } } if(qqb$err["sim"]){ if(sum(SI.c)>0){ - lines(x.c, qqb$crit[SI.c,"sim.right"], + if(datax){ + lines(x.c, qqb$crit[SI.c,"sim.right"], col=col.sCI,lty=lty.sCI,lwd=lwd.sCI) - lines(x.c, qqb$crit[SI.c,"sim.left"], + lines(x.c, qqb$crit[SI.c,"sim.left"], col=col.sCI,lty=lty.sCI,lwd=lwd.sCI) + }else{ + lines(qqb$crit[SI.c,"sim.right"], x.c, + col=col.sCI,lty=lty.sCI,lwd=lwd.sCI) + lines(qqb$crit[SI.c,"sim.left"], x.c, + col=col.sCI,lty=lty.sCI,lwd=lwd.sCI) + } } if(sum(!SI.c)>0){ - points(x.d, qqb$crit[!SI.c,"sim.right"], + if(datax){ + points(x.d, qqb$crit[!SI.c,"sim.right"], col=col.sCI, pch=pch.sCI, cex = cex.sCI) - points(x.d, qqb$crit[!SI.c,"sim.left"], + points(x.d, qqb$crit[!SI.c,"sim.left"], col=col.sCI, pch=pch.sCI, cex = cex.sCI) + }else{ + points(qqb$crit[!SI.c,"sim.right"], x.d, + col=col.sCI, pch=pch.sCI, cex = cex.sCI) + points(qqb$crit[!SI.c,"sim.left"], x.d, + col=col.sCI, pch=pch.sCI, cex = cex.sCI) + } } } if(with.legend){ @@ -301,7 +331,7 @@ merge = FALSE, cex = legend.cex), lcl)) } } - return(invisible(NULL)) + return(invisible(qqb)) } .deleteItemsMCL <- function(mcl){ Modified: branches/distr-2.6/pkg/distr/R/qqplot.R =================================================================== --- branches/distr-2.6/pkg/distr/R/qqplot.R 2014-05-15 12:55:05 UTC (rev 935) +++ branches/distr-2.6/pkg/distr/R/qqplot.R 2014-06-26 22:18:28 UTC (rev 936) @@ -73,9 +73,9 @@ if(mfColRow) opar1 <- par(mfrow = c(1,1), no.readonly = TRUE) ret <- do.call(stats::qqplot, args=mcl) - - if(withIdLine&& plot.it){ - abline(0,1,col=col.IdL,lty=lty.IdL,lwd=lwd.IdL) + qqb <- NULL + if(withIdLine){ + if(plot.it)abline(0,1,col=col.IdL,lty=lty.IdL,lwd=lwd.IdL) if(#is(y,"AbscontDistribution") && withConf){ xy <- unique(sort(c(xc.o,yc.o))) @@ -97,7 +97,8 @@ xy <- sort(c(xy,xy0,xy1)) } } - .confqq(xy, y, withConf.pw, withConf.sim, alpha.CI, + if(plot.it){ + qqb <- .confqq(xy, y, datax=TRUE, withConf.pw, withConf.sim, alpha.CI, col.pCI, lty.pCI, lwd.pCI, pch.pCI, cex.pCI, col.sCI, lty.sCI, lwd.sCI, pch.sCI, cex.sCI, n, exact.sCI = exact.sCI, exact.pCI = exact.pCI, @@ -105,8 +106,12 @@ legend.bg = legend.bg, legend.pos = legend.pos, legend.cex = legend.cex, legend.pref = legend.pref, legend.postf = legend.postf, legend.alpha = legend.alpha) + }else{ + qqb <- qqbounds(sort(unique(xy)),y,alpha.CI,n,withConf.pw, withConf.sim, + exact.sCI,exact.pCI,nosym.pCI) + } } } - return(ret) + return(c(ret,qqb)) }) Modified: branches/distr-2.6/pkg/distr/man/internals-qqplot.Rd =================================================================== --- branches/distr-2.6/pkg/distr/man/internals-qqplot.Rd 2014-05-15 12:55:05 UTC (rev 935) +++ branches/distr-2.6/pkg/distr/man/internals-qqplot.Rd 2014-06-26 22:18:28 UTC (rev 936) @@ -33,14 +33,14 @@ .q2kolmogorov(alpha,n,exact=(n<100)) .q2pw(x,p.b,D,n,alpha,exact=(n<100),nosym=FALSE) -.confqq(x,D, withConf.pw = TRUE, withConf.sim = TRUE, alpha, +.confqq(x,D, datax=TRUE, withConf.pw = TRUE, withConf.sim = TRUE, alpha, col.pCI, lty.pCI, lwd.pCI, pch.pCI, cex.pCI, col.sCI, lty.sCI, lwd.sCI, pch.sCI, cex.sCI, n,exact.sCI=(n<100),exact.pCI=(n<100), nosym.pCI = FALSE, with.legend = TRUE, legend.bg = "white", legend.pos = "topleft", legend.cex = 0.8, legend.pref = "", legend.postf = "", - legend.alpha = alpha) + legend.alpha = alpha, qqb0 = NULL) .deleteItemsMCL(mcl) .distrExInstalled @@ -54,6 +54,7 @@ object. } \item{D}{object of class \code{"UnivariateDistribution"}} +\item{datax}{logical; (to be used in \pkg{distrMod}) shall data be plotted on x-axis?} \item{ord}{integer; the result of a call to \code{order}} \item{alpha}{numeric in [0,1]; confidence level} \item{n}{integer; sample size} @@ -92,6 +93,7 @@ \item{legend.postf}{character to be appended to legend text} \item{legend.alpha}{nominal coverage probability} \item{mcl}{arguments in call as a list} +\item{qqb0}{precomputed return value of \code{qqbounds}} } \details{ @@ -157,7 +159,7 @@ columns will be filled with \code{NA}. \code{.confqq} calls \code{qqbound} to compute the confidence intervals -and plots them. +and plots them; returns the return value of qqbound. \code{.deleteItemsMCL} deletes arguments from a call list which functions like \code{plot}, \code{lines}, \code{points} cannot digest; Modified: branches/distr-2.6/pkg/distr/man/qqplot.Rd =================================================================== --- branches/distr-2.6/pkg/distr/man/qqplot.Rd 2014-05-15 12:55:05 UTC (rev 935) +++ branches/distr-2.6/pkg/distr/man/qqplot.Rd 2014-06-26 22:18:28 UTC (rev 936) @@ -105,6 +105,11 @@ \item{x}{The x coordinates of the points that were/would be plotted} \item{y}{The corresponding quantiles of the second distribution, \emph{including \code{\link{NA}}s}.} + \item{crit}{A matrix with the lower and upper confidence bounds + (computed by \code{qqbounds}).} + \item{err}{logical vector of length 2.} + (elements \code{crit} and \code{err} are taken from the return + value(s) of \code{qqbounds}). } \references{ Becker, R. A., Chambers, J. M. and Wilks, A. R. (1988) Modified: branches/distr-2.6/pkg/distrMod/NAMESPACE =================================================================== --- branches/distr-2.6/pkg/distrMod/NAMESPACE 2014-05-15 12:55:05 UTC (rev 935) +++ branches/distr-2.6/pkg/distrMod/NAMESPACE 2014-06-26 22:18:28 UTC (rev 936) @@ -60,7 +60,7 @@ exportMethods("scaleshapename", "scalename", "LogDeriv") exportMethods("coerce", "profile", "locscalename", "scaleshapename<-") exportMethods("mleCalc", "mceCalc") -exportMethods("qqplot") +exportMethods("qqplot", "returnlevelplot") export("distrModMASK") export("trafoEst") export("distrModOptions", "distrModoptions", "getdistrModOption", Modified: branches/distr-2.6/pkg/distrMod/R/AllGeneric.R =================================================================== --- branches/distr-2.6/pkg/distrMod/R/AllGeneric.R 2014-05-15 12:55:05 UTC (rev 935) +++ branches/distr-2.6/pkg/distrMod/R/AllGeneric.R 2014-06-26 22:18:28 UTC (rev 936) @@ -287,3 +287,6 @@ if(!isGeneric("scalename")){ setGeneric("scalename", function(object) standardGeneric("scalename")) } +if(!isGeneric("returnlevelplot")){ + setGeneric("returnlevelplot", function(x, y, ...) standardGeneric("returnlevelplot")) +} Modified: branches/distr-2.6/pkg/distrMod/R/qqplot.R =================================================================== --- branches/distr-2.6/pkg/distrMod/R/qqplot.R 2014-05-15 12:55:05 UTC (rev 935) +++ branches/distr-2.6/pkg/distrMod/R/qqplot.R 2014-06-26 22:18:28 UTC (rev 936) @@ -49,6 +49,7 @@ withConf.pw = withConf, ### shall pointwise confidence lines be plotted withConf.sim = withConf, ### shall simultaneous confidence lines be plotted plot.it = TRUE, ### shall be plotted at all (inherited from stats::qqplot) + datax = FALSE, ### as in qqnorm xlab = deparse(substitute(x)), ## x-label ylab = deparse(substitute(y)), ## y-label ..., ## further parameters @@ -174,12 +175,15 @@ if(withLab&& plot.it){ lbprep <- .labelprep(xj,yc,lab.pts, col.lbl,cex.lbl,which.lbs,which.Order,order.traf) - text(x = lbprep$x0, y = lbprep$y0, labels = lbprep$lab, + xlb0 <- if(datax) lbprep$x0 else lbprep$y0 + ylb0 <- if(datax) lbprep$y0 else lbprep$x0 + text(x = xlb0, y = ylb0, labels = lbprep$lab, cex = lbprep$cex, col = lbprep$col, adj = adj.lbl) } - if(withIdLine&& plot.it){ - abline(0,1,col=col.IdL,lty=lty.IdL,lwd=lwd.IdL) + qqb <- NULL + if(withIdLine){ + if(plot.it) abline(0,1,col=col.IdL,lty=lty.IdL,lwd=lwd.IdL) if(#is(y,"AbscontDistribution")&& withConf){ xy <- unique(sort(c(x,yc.o))) @@ -202,7 +206,8 @@ } } - .confqq(xy, y, withConf.pw, withConf.sim, alpha.CI, + if(plot.it){ + qqb <- .confqq(xy, y, datax, withConf.pw, withConf.sim, alpha.CI, col.pCI, lty.pCI, lwd.pCI, pch.pCI, cex.pCI, col.sCI, lty.sCI, lwd.sCI, pch.sCI, cex.sCI, n, exact.sCI = exact.sCI, exact.pCI = exact.pCI, @@ -210,9 +215,13 @@ legend.bg = legend.bg, legend.pos = legend.pos, legend.cex = legend.cex, legend.pref = legend.pref, legend.postf = legend.postf, legend.alpha = legend.alpha) + }else{ + qqb <- qqbounds(sort(unique(xy)),y,alpha.CI,n,withConf.pw, withConf.sim, + exact.sCI,exact.pCI,nosym.pCI) + } } } - return(ret) + return(c(ret,qqb)) }) ## into distrMod Added: branches/distr-2.6/pkg/distrMod/R/returnlevelplot.R =================================================================== --- branches/distr-2.6/pkg/distrMod/R/returnlevelplot.R (rev 0) +++ branches/distr-2.6/pkg/distrMod/R/returnlevelplot.R 2014-06-26 22:18:28 UTC (rev 936) @@ -0,0 +1,261 @@ +################################################################ +# return level - Plot functions in package distrMod +################################################################ + + +setMethod("returnlevelplot", signature(x = "ANY", + y = "UnivariateDistribution"), + function(x, ### observations + y, ### distribution + n = length(x), ### number of points to be plotted + withIdLine = TRUE, ### shall line y=x be plotted in + withConf = TRUE, ### shall confidence lines be plotted + withConf.pw = withConf, ### shall pointwise confidence lines be plotted + withConf.sim = withConf, ### shall simultaneous confidence lines be plotted + plot.it = TRUE, ### shall be plotted at all (inherited from stats::qqplot) + datax = FALSE, ### as in qqnorm + MaxOrPOT = c("Max","POT"), ### used for block maxima or points over threshold + npy = 365, ### number of observations per year + xlab = deparse(substitute(x)), ## x-label + ylab = deparse(substitute(y)), ## y-label + main = "", + ..., ## further parameters + width = 10, ## width (in inches) of the graphics device opened + height = 5.5, ## height (in inches) of the graphics device opened} + withSweave = getdistrOption("withSweave"), ## logical: if \code{TRUE} + ## (for working with \command{Sweave}) no extra device is opened and height/width are not set + mfColRow = TRUE, ## shall we use panel partition mfrow=c(1,1)? + n.CI = n, ## number of points to be used for CI + withLab = FALSE, ## shall observation labels be plotted in + lab.pts = NULL, ## observation labels to be used + which.lbs = NULL, ## which observations shall be labelled + which.Order = NULL, ## which of the ordered (remaining) observations shall be labelled + order.traf = NULL, ## an optional trafo; by which the observations are ordered (as order(trafo(obs)) + col.IdL = "red", ## color for the identity line + lty.IdL = 2, ## line type for the identity line + lwd.IdL = 2, ## line width for the identity line + alpha.CI = .95, ## confidence level + exact.pCI = (n<100), ## shall pointwise CIs be determined with exact Binomial distribution? + exact.sCI = (n<100), ## shall simultaneous CIs be determined with exact kolmogorov distribution? + nosym.pCI = FALSE, ## shall we use (shortest) asymmetric CIs? + col.pCI = "orange", ## color for the pointwise CI + lty.pCI = 3, ## line type for the pointwise CI + lwd.pCI = 2, ## line width for the pointwise CI + pch.pCI = par("pch"),## symbol for points (for discrete mass points) in pointwise CI + cex.pCI = par("cex"),## magnification factor for points (for discrete mass points) in pointwise CI + col.sCI = "tomato2", ## color for the simultaneous CI + lty.sCI = 4, ## line type for the simultaneous CI + lwd.sCI = 2, ## line width for the simultaneous CI + pch.sCI = par("pch"),## symbol for points (for discrete mass points) in simultaneous CI + cex.sCI = par("cex"),## magnification factor for points (for discrete mass points) in simultaneous CI + cex.pch = par("cex"),## magnification factor for the plotted symbols + col.pch = par("col"),## color for the plotted symbols + cex.lbl = par("cex"),## magnification factor for the plotted observation labels + col.lbl = par("col"),## color for the plotted observation labels + adj.lbl = NULL, ## adj parameter for the plotted observation labels + alpha.trsp = NA, ## alpha transparency to be added afterwards + jit.fac = 0, ## jittering factor used for discrete distributions + check.NotInSupport = TRUE, ## shall we check if all x lie in support(y) + col.NotInSupport = "red", ## if preceding check TRUE color of x if not in support(y) + with.legend = TRUE, ## shall a legend be plotted + legend.bg = "white", ## background for the legend + legend.pos = "topleft", ## position for the legend + legend.cex = 0.8, ## magnification factor for the legend + legend.pref = "", ## prefix for legend text + legend.postf = "", ## postfix for legend text + legend.alpha = alpha.CI ## nominal level of CI + ){ ## return value as in stats::qqplot + + MaxOrPOT <- match.arg(MaxOrPOT) + mc <- match.call(call = sys.call(sys.parent(1))) + if(missing(xlab)) mc$xlab <- paste(gettext("Return level of"), + as.character(deparse(mc$x))) + if(missing(ylab)) mc$ylab <- gettext("Return period (years)") + if(missing(main)) mc$main <- gettext("Return level plot") + mcl <- as.list(mc)[-1] + mcl$MaxOrPOT <- NULL + mcl$npy <- NULL + mcl$withSweave <- NULL + mcl$mfColRow <- NULL + mcl$type <-NULL + force(x) + + + xj <- x + if(any(.isReplicated(x))) + xj[.isReplicated(x)] <- jitter(x[.isReplicated(x)], factor=jit.fac) + + ord.x <- order(xj) + + p2rl <- function(pp){ + pp <- p(y)(pp) + return(if(MaxOrPOT=="Max") -1/log(pp) else 1/(1-pp)/npy) + } + + pp <- ppoints(n) + yc.o <- q(y)(pp) + ycl <- p2rl(yc.o) + + ### extend range somewhat + xyall <- sort(unique(c(yc.o,x, + q(y)(c(seq(0.01, 0.09, by = 0.01),(1:9)/10, + 0.95, 0.99, 0.995, 0.999)), + 10^(seq(-1, 3.75 + log10(npy), by = 0.1)) + ))) + rxyall <- (max(xyall)-min(xyall))*0.6 + rxymean <- (max(xyall)+min(xyall))/2 + + xyallc <- seq(rxymean-rxyall,rxymean+rxyall, length.out=300) + pxyallc <- p2rl(xyallc) + xyallc <- xyallc[pxyallc>0.00001 & pxyallc<0.99999] + pxyallc <- pxyallc[pxyallc>0.00001 & pxyallc<0.99999] + + if("support" %in% names(getSlots(class(y)))) + ycl <- sort(jitter(ycl, factor=jit.fac)) + + alp.v <- .makeLenAndOrder(alpha.trsp,ord.x) + alp.t <- function(x,a1) if(is.na(x)) x else addAlphTrsp2col(x,a1) + alp.f <- if(length(alpha.trsp)==1L && is.na(alpha.trsp)) + function(x,a) x else function(x,a) mapply(x,alp.t,a1=a) + cex.pch <- .makeLenAndOrder(cex.pch,ord.x) + cex.lbl <- .makeLenAndOrder(cex.lbl,ord.x) + col.pch <- alp.f(.makeLenAndOrder(col.pch,ord.x),alp.v) + col.lbl <- alp.f(.makeLenAndOrder(col.lbl,ord.x),alp.v) + + if(withLab){ + if(is.null(lab.pts)) lab.pts <- paste(ord.x) + else lab.pts <- .makeLenAndOrder(lab.pts,ord.x) + } + + if(check.NotInSupport){ + xo <- x[ord.x] + nInSupp <- which(xo < q(y)(0)) + + nInSupp <- unique(sort(c(nInSupp,which( xo > q(y)(1))))) + if("support" %in% names(getSlots(class(y)))) + nInSupp <- unique(sort(c(nInSupp,which( ! xo %in% support(y))))) + if("gaps" %in% names(getSlots(class(y)))) + nInSupp <- unique(sort(c(nInSupp,which( .inGaps(xo,gaps(y)))))) + if(length(nInSupp)){ + col.pch[nInSupp] <- col.NotInSupport + if(withLab) +# col.lbl[ord.x[nInSupp]] <- col.NotInSupport + col.lbl[nInSupp] <- col.NotInSupport + } + } + + + if(n!=length(x)) withLab <- FALSE + + mcl <- .deleteItemsMCL(mcl) + mcl$cex <- cex.pch + mcl$col <- col.pch + + if (!withSweave){ + devNew(width = width, height = height) + } + opar <- par("mfrow", no.readonly = TRUE) + if(mfColRow) on.exit(do.call(par, list(mfrow=opar, no.readonly = TRUE))) + + if(mfColRow) opar1 <- par(mfrow = c(1,1), no.readonly = TRUE) + + ret <- list(x=xj,y=ycl) + + if(plot.it){ + xallc1 <- sort(c(xj,xyallc)) + yallc1 <- sort(c(ycl,pxyallc)) + mcl$x <- mcl$y <- NULL + 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)) + # 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)) + } + } + + if(withLab&& plot.it){ + lbprep <- .labelprep(xj,yc.o,lab.pts, + col.lbl,cex.lbl,which.lbs,which.Order,order.traf) + lbprep$y0 <- p2rl(lbprep$y0) + xlb0 <- if(datax) lbprep$x0 else lbprep$y0 + ylb0 <- if(datax) lbprep$y0 else lbprep$x0 + text(x = xlb0, y = ylb0, labels = lbprep$lab, + cex = lbprep$cex, col = lbprep$col, adj = adj.lbl) + } + + if(withIdLine){ + if(plot.it){ + if(datax){ + lines(xyallc,pxyallc,col=col.IdL,lty=lty.IdL,lwd=lwd.IdL) + }else{ + lines(pxyallc,xyallc,col=col.IdL,lty=lty.IdL,lwd=lwd.IdL) + } + } + qqb <- NULL + if(#is(y,"AbscontDistribution")&& + withConf){ + xy <- unique(sort(c(x,yc.o))) + xy <- xy[!.NotInSupport(xy,y)] + lxy <- length(xy) + if(is(y,"DiscreteDistribution")){ + n0 <- min(n.CI, length(support(y))) + n1 <- max(n0-lxy,0) + if (n1 >0 ){ + notyetInXY <- setdiff(support(y), xy) + xy0 <- sample(notyetInXY, n1) + xy <- sort(unique(c(xy,xy0))) + } + }else{ + if(lxy < n.CI){ + n1 <- (n.CI-lxy)%/%3 + xy0 <- seq(min(xy),max(xy),length=n1) + xy1 <- r(y)(n.CI-lxy-n1) + xy <- sort(unique(c(xy,xy0,xy1))) + } + } + + qqb <- qqbounds(sort(unique(xy)),y,alpha.CI,n,withConf.pw, withConf.sim, + exact.sCI,exact.pCI,nosym.pCI) + qqb$crit <- p2rl(qqb$crit) + if(plot.it){ + qqb <- .confqq(xy, y, datax, withConf.pw, withConf.sim, alpha.CI, + col.pCI, lty.pCI, lwd.pCI, pch.pCI, cex.pCI, + col.sCI, lty.sCI, lwd.sCI, pch.sCI, cex.sCI, + n, exact.sCI = exact.sCI, exact.pCI = exact.pCI, + nosym.pCI = nosym.pCI, 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, + qqb0=qqb) + } + }} + return(c(ret,qqb)) + }) + +## into distrMod +setMethod("returnlevelplot", signature(x = "ANY", + y = "ProbFamily"), function(x, y, + n = length(x), withIdLine = TRUE, withConf = TRUE, + withConf.pw = withConf, withConf.sim = withConf, + plot.it = TRUE, xlab = deparse(substitute(x)), + ylab = deparse(substitute(y)), ...){ + + mc <- match.call(call = sys.call(sys.parent(1))) + if(missing(xlab)) mc$xlab <- as.character(deparse(mc$x)) + if(missing(ylab)) mc$ylab <- as.character(deparse(mc$y)) + mcl <- as.list(mc)[-1] + + mcl$y <- yD <- y at distribution + if(!is(yD,"UnivariateDistribution")) + stop("Not yet implemented.") + + return(do.call(getMethod("returnlevelplot", signature(x="ANY", y="UnivariateDistribution")), + args=mcl)) + }) + Modified: branches/distr-2.6/pkg/distrMod/man/qqplot.Rd =================================================================== --- branches/distr-2.6/pkg/distrMod/man/qqplot.Rd 2014-05-15 12:55:05 UTC (rev 935) +++ branches/distr-2.6/pkg/distrMod/man/qqplot.Rd 2014-06-26 22:18:28 UTC (rev 936) @@ -6,7 +6,8 @@ \S4method{qqplot}{ANY,UnivariateDistribution}(x,y, n = length(x), withIdLine = TRUE, withConf = TRUE, withConf.pw = withConf, withConf.sim = withConf, - plot.it = TRUE, xlab = deparse(substitute(x)),ylab = deparse(substitute(y)), + plot.it = TRUE, datax = FALSE, xlab = deparse(substitute(x)), + ylab = deparse(substitute(y)), ..., width = 10, height = 5.5, withSweave = getdistrOption("withSweave"), mfColRow = TRUE, n.CI = n, withLab = FALSE, lab.pts = NULL, which.lbs = NULL, which.Order = NULL, order.traf = NULL, @@ -45,6 +46,7 @@ \item{withConf.sim}{logical; shall simultaneous confidence lines be plotted?} \item{plot.it}{logical; shall be plotted at all (inherited from \code{\link[stats:qqnorm]{qqplot}})?} +\item{datax}{logical; shall data be plotted on x-axis?} \item{xlab}{x-label} \item{ylab}{y-label} \item{\dots}{further parameters for method \code{qqplot} with signature @@ -122,6 +124,11 @@ \item{x}{The x coordinates of the points that were/would be plotted} \item{y}{The corresponding quantiles of the second distribution, \emph{including \code{\link{NA}}s}.} + \item{crit}{A matrix with the lower and upper confidence bounds + (computed by \code{qqbounds}).} + \item{err}{logical vector of length 2.} + (elements \code{crit} and \code{err} are taken from the return + value(s) of \code{qqbounds}). } \details{ \describe{ Added: branches/distr-2.6/pkg/distrMod/man/returnlevelplot.Rd =================================================================== --- branches/distr-2.6/pkg/distrMod/man/returnlevelplot.Rd (rev 0) +++ branches/distr-2.6/pkg/distrMod/man/returnlevelplot.Rd 2014-06-26 22:18:28 UTC (rev 936) @@ -0,0 +1,175 @@ +\name{returnlevelplot} +\docType{methods} +\title{Methods for Function returnlevelplot in Package `distrMod'} +\usage{ +returnlevelplot(x, y, ...) +\S4method{returnlevelplot}{ANY,UnivariateDistribution}(x,y, + n = length(x), withIdLine = TRUE, + withConf = TRUE, withConf.pw = withConf, withConf.sim = withConf, + plot.it = TRUE, datax = FALSE, MaxOrPOT = c("Max","POT"), npy = 365, + xlab = deparse(substitute(x)), + ylab = deparse(substitute(y)), + main = "", + ..., width = 10, height = 5.5, withSweave = getdistrOption("withSweave"), + mfColRow = TRUE, n.CI = n, withLab = FALSE, lab.pts = NULL, which.lbs = NULL, + which.Order = NULL, order.traf = NULL, + col.IdL = "red", lty.IdL = 2, lwd.IdL = 2, alpha.CI = .95, + exact.pCI = (n<100), exact.sCI = (n<100), nosym.pCI = FALSE, + col.pCI = "orange", lty.pCI = 3, lwd.pCI = 2, pch.pCI = par("pch"), + cex.pCI = par("cex"), + col.sCI = "tomato2", lty.sCI = 4, lwd.sCI = 2, pch.sCI = par("pch"), + cex.sCI = par("cex"), + cex.pch = par("cex"), col.pch = par("col"), + cex.lbl = par("cex"), col.lbl = par("col"), adj.lbl = NULL, + alpha.trsp = NA, jit.fac = 0, + check.NotInSupport = TRUE, col.NotInSupport = "red", + with.legend = TRUE, legend.bg = "white", + legend.pos = "topleft", legend.cex = 0.8, + legend.pref = "", legend.postf = "", legend.alpha = alpha.CI) +\S4method{returnlevelplot}{ANY,ProbFamily}(x, y, + n = length(x), withIdLine = TRUE, withConf = TRUE, + withConf.pw = withConf, withConf.sim = withConf, + plot.it = TRUE, xlab = deparse(substitute(x)), + ylab = deparse(substitute(y)), ...) +} +\alias{returnlevelplot} +\alias{returnlevelplot-methods} +\alias{returnlevelplot,ANY,ProbFamily-method} +\alias{returnlevelplot,ANY,UnivariateDistribution-method} + +\arguments{ +\item{x}{data to be checked for compatibility with distribution/model \code{y}.} +\item{y}{object of class \code{"UnivariateDistribution"} or of +class \code{"ProbFamily"}.} +\item{n}{numeric; assumed sample size (by default length of \code{x}).} +\item{withIdLine}{logical; shall line \code{y = x} be plotted in?} +\item{withConf}{logical; shall confidence lines be plotted?} +\item{withConf.pw}{logical; shall pointwise confidence lines be plotted?} +\item{withConf.sim}{logical; shall simultaneous confidence lines be plotted?} +\item{plot.it}{logical; shall be plotted at all (inherited from +\code{\link[stats:qqnorm]{returnlevelplot}})?} +\item{datax}{logical; shall data be plotted on x-axis?} +\item{MaxOrPOT}{a character string specifying whether it is used for + block maxima ("Max") or for points over threshold ("POT"); + must be one of ?"Max"? (default) or ?"POT"?. + You can specify just the initial letter.} +\item{npy}{number of observations per year/block.} +\item{main}{Main title} +\item{xlab}{x-label} +\item{ylab}{y-label} +\item{\dots}{further parameters for method \code{returnlevelplot} with signature +\code{ANY,UnivariateDistribution} or with function \code{plot}} +\item{width}{width (in inches) of the graphics device opened} +\item{height}{height (in inches) of the graphics device opened} +\item{withSweave}{logical: if \code{TRUE} (for working with \command{Sweave}) + no extra device is opened and height/width are not set} +\item{mfColRow}{shall default partition in panels be used --- defaults to \code{TRUE}} +\item{n.CI}{numeric; number of points to be used for confidence interval} +\item{withLab}{logical; shall observation labels be plotted in?} +\item{lab.pts}{character or \code{NULL}; observation labels to be used} +\item{which.lbs}{integer or \code{NULL}; which observations shall be labelled} +\item{which.Order}{integer or \code{NULL}; which of the ordered (remaining) +observations shall be labelled} +\item{order.traf}{function or \code{NULL}; an optional trafo by which the +observations are ordered (as order(trafo(obs)).} +\item{col.IdL}{color for the identity line} +\item{lty.IdL}{line type for the identity line} +\item{lwd.IdL}{line width for the identity line} +\item{alpha.CI}{confidence level} +\item{exact.pCI}{logical; shall pointwise CIs be determined with exact +Binomial distribution?} +\item{exact.sCI}{logical; shall simultaneous CIs be determined with +exact Kolmogorov distribution?} +\item{nosym.pCI}{logical; shall we use (shortest) asymmetric CIs?} +\item{col.pCI}{color for the pointwise CI} +\item{lty.pCI}{line type for the pointwise CI} +\item{lwd.pCI}{line width for the pointwise CI} +\item{pch.pCI}{symbol for points (for discrete mass points) in pointwise CI} +\item{cex.pCI}{magnification factor for points (for discrete mass points) in +pointwise CI} +\item{col.sCI}{color for the simultaneous CI} +\item{lty.sCI}{line type for the simultaneous CI} +\item{lwd.sCI}{line width for the simultaneous CI} +\item{pch.sCI}{symbol for points (for discrete mass points) in simultaneous CI} +\item{cex.sCI}{magnification factor for points (for discrete mass points) in +simultaneous CI} +\item{cex.pch}{magnification factor for the plotted symbols} +\item{col.pch}{color for the plotted symbols} +\item{cex.lbl}{magnification factor for the plotted observation labels} +\item{col.lbl}{color for the plotted observation labels} [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/distr -r 936 From noreply at r-forge.r-project.org Fri Jun 27 00:52:19 2014 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Fri, 27 Jun 2014 00:52:19 +0200 (CEST) Subject: [Distr-commits] r937 - branches/distr-2.6/pkg/distrMod/R Message-ID: <20140626225219.4AF48186153@r-forge.r-project.org> Author: ruckdeschel Date: 2014-06-27 00:52:18 +0200 (Fri, 27 Jun 2014) New Revision: 937 Modified: branches/distr-2.6/pkg/distrMod/R/returnlevelplot.R Log: noch eine Kleinigkeit rausgenommen Modified: branches/distr-2.6/pkg/distrMod/R/returnlevelplot.R =================================================================== --- branches/distr-2.6/pkg/distrMod/R/returnlevelplot.R 2014-06-26 22:18:28 UTC (rev 936) +++ branches/distr-2.6/pkg/distrMod/R/returnlevelplot.R 2014-06-26 22:52:18 UTC (rev 937) @@ -97,19 +97,25 @@ ycl <- p2rl(yc.o) ### extend range somewhat - xyall <- sort(unique(c(yc.o,x, +# pyn <- p(y)(10^(seq(-1, 3.75 + log10(npy), by = 0.1))) + xyall <- force(sort(unique(c(yc.o,x, q(y)(c(seq(0.01, 0.09, by = 0.01),(1:9)/10, - 0.95, 0.99, 0.995, 0.999)), - 10^(seq(-1, 3.75 + log10(npy), by = 0.1)) - ))) - rxyall <- (max(xyall)-min(xyall))*0.6 + 0.95, 0.99, 0.995, 0.999)) + )))) + rxyall <- (max(xyall)-min(xyall))*0.6 rxymean <- (max(xyall)+min(xyall))/2 - xyallc <- seq(rxymean-rxyall,rxymean+rxyall, length.out=300) + xyallc <- seq(from=rxymean-rxyall,to=rxymean+rxyall, length.out=300) + print(xyallc) + pxyall <- p(y)(xyallc) + print(pxyall) + pxyallc <- p2rl(xyallc) - xyallc <- xyallc[pxyallc>0.00001 & pxyallc<0.99999] - pxyallc <- pxyallc[pxyallc>0.00001 & pxyallc<0.99999] + xyallc <- xyallc[pxyall>0.00001 & pxyall<0.99999] + pxyallc <- pxyallc[pxyall>0.00001 & pxyall<0.99999] + print(cbind(pxyallc,xyallc)) + if("support" %in% names(getSlots(class(y)))) ycl <- sort(jitter(ycl, factor=jit.fac))