Nothing
# -------- AbscontDistribution ---------- #
setMethod("plot", signature(x = "AbscontDistribution", y = "missing"),
function(x, width = 10, height = 5.5, withSweave = getdistrOption("withSweave"),
xlim = NULL, ylim = NULL, ngrid = 1000, verticals = TRUE,
do.points = TRUE, main = FALSE, inner = TRUE, sub = FALSE,
bmar = par("mar")[1], tmar = par("mar")[3], ...,
cex.main = par("cex.main"), cex.inner = 1.2,
cex.sub = par("cex.sub"), col.points = par("col"),
col.vert = par("col"), col.main = par("col.main"),
col.inner = par("col.main"), col.sub = par("col.sub"),
cex.points = 2.0, pch.u = 21, pch.a = 16, mfColRow = TRUE,
to.draw.arg = NULL, withSubst = TRUE){
mc <- match.call(call = sys.call(sys.parent(1)))
xc <- mc$x
### manipulating the ... - argument
dots <- match.call(call = sys.call(sys.parent(1)),
expand.dots = FALSE)$"..."
to.draw <- 1:3
names(to.draw) <- c("d","p","q")
if(! is.null(to.draw.arg)){
if(is.character(to.draw.arg))
to.draw <- pmatch(to.draw.arg, names(to.draw))
else if(is.numeric(to.draw.arg))
to.draw <- to.draw.arg
}
l.draw <- length(to.draw)
pF <- expression({})
if(!is.null(dots[["panel.first"]])){
pF <- .panel.mingle(dots,"panel.first")
}
pF <- .fillList(pF, l.draw)
pL <- expression({})
if(!is.null(dots[["panel.last"]])){
pL <- .panel.mingle(dots,"panel.last")
}
pL <- .fillList(pL, l.draw)
plotInfo <- list(call = mc, dots=dots,
args = list(width = width, height = height,
withSweave = withSweave,
xlim = xlim, ylim = ylim, ngrid = ngrid,
verticals = verticals, do.points = do.points,
main = main, inner = inner, sub = sub,
bmar = bmar, tmar = tmar, cex.main = cex.main,
cex.inner = cex.inner, cex.sub = cex.sub,
col.points = col.points, col.vert = col.vert,
col.main = col.main, col.inner = col.inner,
col.sub = col.sub, cex.points = cex.points,
pch.u = pch.u, pch.a = pch.a, mfColRow = mfColRow,
to.draw.arg = to.draw.arg, withSubst = withSubst),
to.draw=to.draw, panelFirst = pF,
panelLast = pL)
plotInfo$to.draw <- to.draw
plotInfo$panelFirst <- pF
plotInfo$panelLast <- pL
dots$panel.first <- dots$panel.last <- NULL
dots$col.hor <- NULL
dots.for.points <- .makedotsPt(dots)
dots.lowlevel <- .makedotsLowLevel(dots)
dots.without.pch <- dots.lowlevel[! (names(dots.lowlevel) %in% c("col", "pch"))]
if(!is(x,"AbscontDistribution"))
x <- .ULC.cast(x)
###
if(!is.logical(inner))
{if(!is.list(inner))
inner <- as.list(inner)
#stop("Argument 'inner' must either be 'logical' or a 'list'")
inner <- .fillList(inner,l.draw)
}
cex <- if (hasArg("cex")) dots$cex else 1
if (hasArg("cex") && missing(cex.points))
cex.points <- 2.0 * cex
if (hasArg("pch") && missing(pch.u))
pch.u <- dots$pch
if (hasArg("pch") && missing(pch.a))
pch.a <- dots$pch
if (hasArg("col") && missing(col.points))
col.points <- dots$col
if (hasArg("col") && missing(col.vert))
col.vert <- dots$col
if (hasArg("col") && missing(col.main))
col.main <- dots$col
if (hasArg("col") && missing(col.inner))
col.inner <- dots$col
if (hasArg("col") && missing(col.sub))
col.sub <- dots$col
if (!withSweave){
devNew(width = width, height = height)
}
omar <- par("mar", no.readonly = TRUE)
# omar$cin <- omar$cra <- omar$csi <- omar$cxy <- omar$din <- NULL
if(mfColRow) on.exit(par(omar, no.readonly = TRUE))
mainL <- FALSE
subL <- FALSE
lineT <- NA
logpd <- logq <- ""
slots <- slotNames(param(x))
slots <- slots[slots != "name"]
nrvalues <- length(slots)
if(nrvalues > 0){
values <- numeric(nrvalues)
for(i in 1:nrvalues)
values[i] <- attributes(attributes(x)$param)[[slots[i]]]
paramstring <- paste(values, collapse = ", ")
nparamstring <- paste(slots, "=", values, collapse = ", ")
qparamstring <- paste("(",paramstring,")",sep="")
}
else paramstring <- qparamstring <- nparamstring <- ""
.mpresubs <- if(withSubst){
function(inx)
.presubs(inx, c("%C", "%D", "%N", "%P", "%Q", "%A"),
c(as.character(class(x)[1]),
as.character(date()),
nparamstring,
paramstring,
qparamstring,
as.character(deparse(xc))))
}else function(inx) inx
xlab0 <- list("d"="x", "p"="q", "q"="p")
iL <- 1:length(to.draw)
.mp2 <- function(dlb = dots$xlab, lb0 = list("d"="x", "p"="q", "q"="p")){
dlb0 <- eval(dlb)
if (!is.null(dlb)){
.mp <- if(is.list(dlb0)) function(x,i){
if(is.call(x)) x <- eval(x)
if(length(i)==0) return(NULL)
i <- min(i)
if(is.character(x[[i]])){
return(as.character(eval(.mpresubs(x[[i]]))))
}else{
res <- .mpresubs(x[[i]])
if(length(res)==0) return(NULL)
if(is.call(res)) res <- res[-1]
return(res)}
}else function(x,i){
if(length(x)==1) return(x[1])
res <- x[i]
if(length(res)==0) return(NULL)
if(is.na(res)) return(NULL)
return(res)}
force(lb0)
.mp3 <- .mp(dlb,iL[to.draw==1])
if(1%in%to.draw & !is.null(.mp3)) lb0[["d"]] <- .mp3
.mp3 <- .mp(dlb,iL[to.draw==2])
if(2%in%to.draw & !is.null(.mp3)) lb0[["p"]] <- .mp3
.mp3 <- .mp(dlb,iL[to.draw==3])
if(3%in%to.draw & !is.null(.mp3)) lb0[["q"]] <- .mp3
}
return(lb0)}
xlab0 <- .mp2()
dots$xlab <- NULL
ylab0 <- .mp2(dlb=dots$ylab, lb0=list("d"="d(x)", "p"="p(q)", "q"="q(p)"))
dots$ylab <- NULL
if (hasArg("main")){
mainL <- TRUE
if (is.logical(main)){
if (!main) mainL <- FALSE
else
main <- gettextf("Distribution Plot for %%A") ###
### double %% as % is special for gettextf
}
main <- .mpresubs(main)
if (mainL) {
if(missing(tmar))
tmar <- 5
if(missing(cex.inner))
cex.inner <- .9
lineT <- 0.6
}
}
if (hasArg("sub")){
subL <- TRUE
if (is.logical(sub)){
if (!sub) subL <- FALSE
else sub <- gettextf("generated %%D")
### double %% as % is special for gettextf
}
sub <- .mpresubs(sub)
if (subL)
if (missing(bmar)) bmar <- 6
}
if(mfColRow)
opar <- par(mfrow = c(1,l.draw), mar = c(bmar,omar[2],tmar,omar[4]), no.readonly = TRUE)
else
opar <- par(mar = c(bmar,omar[2],tmar,omar[4]), no.readonly = TRUE)
if(is.logical(inner)){
inner.d <- if (inner)
.mpresubs(gettextf("Density of %%C%%Q")) else ""
inner.p <- if (inner)
.mpresubs(gettextf("CDF of %%C%%Q")) else ""
inner.q <- if (inner)
.mpresubs(gettextf("Quantile function of %%C%%Q")) else ""
### double %% as % is special for gettextf
}else{
iL <- 1:length(to.draw)
inner.d <- if(1%in%to.draw) .mpresubs(inner[[min(iL[to.draw==1])]]) else NULL
inner.p <- if(2%in%to.draw) .mpresubs(inner[[min(iL[to.draw==2])]]) else NULL
inner.q <- if(3%in%to.draw) .mpresubs(inner[[min(iL[to.draw==3])]]) else NULL
}
lower0 <- getLow(x, eps = getdistrOption("TruncQuantile")*2)
upper0 <- getUp(x, eps = getdistrOption("TruncQuantile")*2)
me <- q.l(x)(1/2); s <- q.l(x)(3/4)-q.l(x)(1/4)
lower1 <- me - 6 * s
upper1 <- me + 6 * s
lower <- max(lower0, lower1)
upper <- min(upper0, upper1)
## ngrid nr of gridpoints
## exactq two p-values are considered equal if difference is
## is less than 10^-exactq in abs. value
dist <- upper - lower
if(hasArg("xlim"))
{if(length(xlim)!=2) stop("Wrong length of Argument xlim");
grid <- seq(xlim[1], xlim[2], length = ngrid)}
else grid <- seq(from = lower - 0.1 * dist, to = upper + 0.1 * dist,
length = ngrid)
dxg <- d(x)(grid)
pxg <- p(x)(grid)
if(hasArg("ylim"))
{if (3 %in% to.draw && any( c(1,2) %in% to.draw)){
if(! length(ylim) %in% c(2,4))
stop("Wrong length of Argument ylim")
}else{
if(! length(ylim) == 2)
stop("Wrong length of Argument ylim")
}
ylim <- matrix(ylim, 2,2)
ylim1 <- ylim[,1]; ylim2 <- ylim[,2];
}
else {ylim1 <- c(0,max(dxg[dxg<50])); ylim2 <- c(-0.05,1.05)}
if(hasArg("log"))
{logpd <- dots$log
logq <- gsub("u","y",gsub("y","x",gsub("x", "u", logpd)))
if(length(grep("y",logpd))){
ylim1 <- c(max(min(dxg[dxg>0]), ylim1[1]),
ylim1[2])
ylim2 <- c(max(min(pxg[pxg>0]), ylim2[1]),
ylim2[2])
}
}
plotCount <- 1
o.warn <- getOption("warn"); options(warn = -1)
if(1%in%to.draw){
on.exit(options(warn=o.warn))
dots.lowlevel$panel.first <- pF[[plotCount]]
dots.lowlevel$panel.last <- pL[[plotCount]]
dots.lowlevel$xlim <- xlim
plotInfo$dplot$plot <- c(list(x = grid, dxg, type = "l",
ylim = ylim1, ylab = ylab0[["d"]], xlab = xlab0[["d"]], log = logpd),
dots.lowlevel)
do.call(plot, c(list(x = grid, dxg, type = "l",
ylim = ylim1, ylab = ylab0[["d"]], xlab = xlab0[["d"]], log = logpd),
dots.lowlevel))
plotInfo$dplot$usr <- par("usr")
dots.lowlevel$panel.first <- dots.lowlevel$panel.last <- NULL
dots.lowlevel$xlim <- NULL
plotCount <- plotCount + 1
options(warn = o.warn)
plotInfo$dplot$title <- list(main = inner.d, line = lineT,
cex.main = cex.inner, col.main = col.inner)
title(main = inner.d, line = lineT, cex.main = cex.inner,
col.main = col.inner)
options(warn = -1)
}
if(is.finite(q.l(x)(0))) {grid <- c(q.l(x)(0),grid); pxg <- c(0,pxg)}
if(is.finite(q.l(x)(1))) {grid <- c(grid,q.l(x)(1)); pxg <- c(pxg,1)}
if(2%in%to.draw){
dots.lowlevel$panel.first <- pF[[plotCount]]
dots.lowlevel$panel.last <- pL[[plotCount]]
dots.lowlevel$xlim <- xlim
plotInfo$pplot$plot <- c(list(x = grid, pxg, type = "l",
ylim = ylim2, ylab = ylab0[["p"]], xlab = xlab0[["p"]], log = logpd),
dots.lowlevel)
do.call(plot, c(list(x = grid, pxg, type = "l",
ylim = ylim2, ylab = ylab0[["p"]], xlab = xlab0[["p"]], log = logpd),
dots.lowlevel))
plotInfo$pplot$usr <- par("usr")
dots.lowlevel$panel.first <- dots.lowlevel$panel.last <- NULL
dots.lowlevel$xlim <- NULL
plotCount <- plotCount + 1
options(warn = o.warn)
plotInfo$pplot$title <- list(main = inner.p, line = lineT,
cex.main = cex.inner, col.main = col.inner)
title(main = inner.p, line = lineT, cex.main = cex.inner,
col.main = col.inner)
}
### quantiles
### fix finite support bounds
ixg <- grid>=max(q.l(x)(0),lower) & grid <= min(q.l(x)(1),upper)
pxg <- pxg[ixg]
grid <- grid[ixg]
### fix constancy regions of p(x)
if(isOldVersion(x)) x <- conv2NewVersion(x)
if(!is.null(gaps(x))){
i.not.gap <- !.isIn(grid,gaps(x))
ndots <- nrow(gaps(x))
pu1 <- p(x)(gaps(x)[,1])
if (verticals){
xu <- c(gaps(x)[,1],gaps(x)[,2], grid[i.not.gap])
pu <- c(rep(pu1,2), pxg[i.not.gap])
}else{
xu <- c(gaps(x)[,1],rep(NA,ndots),gaps(x)[,2], grid[i.not.gap])
pu <- c(rep(pu1,3), pxg[i.not.gap])
}
#
o <- order(pu)
po <- pu[o]
xo <- xu[o]
}else{
po <- pxg
xo <- grid
}
if(3%in%to.draw){
options(warn = -1)
dots.lowlevel$panel.first <- pF[[plotCount]]
dots.lowlevel$panel.last <- pL[[plotCount]]
plotInfo$qplot$plot <- c(list(x = po, xo, type = "n",
xlim = ylim2, ylim = xlim, ylab = ylab0[["q"]], xlab = xlab0[["q"]],
log = logq), dots.lowlevel)
do.call(plot, c(list(x = po, xo, type = "n",
xlim = ylim2, ylim = xlim, ylab = ylab0[["q"]], xlab = xlab0[["q"]],
log = logq), dots.lowlevel))
plotInfo$qplot$usr <- par("usr")
dots.lowlevel$panel.first <- dots.lowlevel$panel.last <- NULL
plotCount <- plotCount + 1
options(warn = o.warn)
plotInfo$qplot$title <- list(main = inner.q, line = lineT,
cex.main = cex.inner, col.main = col.inner)
title(main = inner.q, line = lineT, cex.main = cex.inner,
col.main = col.inner)
options(warn = -1)
lines(po,xo, ...)
if (verticals && !is.null(gaps(x))){
pu <- rep(pu1,3)
xu <- c(gaps(x)[,1],gaps(x)[,2],rep(NA,ndots))
o <- order(pu)
dots.without.pch0 <- dots.without.pch
dots.without.pch0$col <- NULL
do.call(lines, c(list(pu[o], xu[o],
col = col.vert), dots.without.pch0))
plotInfo$qplot$vlines <- c(list(x=pu[o], y=xu[o],
col = col.vert), dots.without.pch0)
}
options(warn = o.warn)
if(!is.null(gaps(x)) && do.points){
do.call(points, c(list(x = pu1, y = gaps(x)[,1], pch = pch.a,
cex = cex.points, col = col.points), dots.for.points) )
do.call(points, c(list(x = pu1, y = gaps(x)[,2], pch = pch.u,
cex = cex.points, col = col.points), dots.for.points) )
plotInfo$qplot$vpoints.l <- c(list(x=pu1, y=gaps(x)[,1],
pch = pch.a, cex = cex.points, col = col.points),
dots.for.points)
plotInfo$qplot$vpoints.r <- c(list(x=pu1, y=gaps(x)[,2],
pch = pch.a, cex = cex.points, col = col.points),
dots.for.points)
}
}
if (mainL){
mtext(text = main, side = 3, cex = cex.main, adj = .5,
outer = TRUE, padj = 1.4, col = col.main)
plotInfo$mainL <- list(text = main, side = 3, cex = cex.main, adj = .5,
outer = TRUE, padj = 1.4, col = col.main)
}
if (subL){
mtext(text = sub, side = 1, cex = cex.sub, adj = .5,
outer = TRUE, line = -1.6, col = col.sub)
plotInfo$subL <- list(text = sub, side = 1, cex = cex.sub, adj = .5,
outer = TRUE, line = -1.6, col = col.sub)
}
class(plotInfo) <- c("plotInfo","DiagnInfo")
return(invisible(plotInfo))
}
)
# -------- DiscreteDistribution -------- #
setMethod("plot", signature(x = "DiscreteDistribution", y = "missing"),
function(x, width = 10, height = 5.5, withSweave = getdistrOption("withSweave"),
xlim = NULL, ylim = NULL, verticals = TRUE, do.points = TRUE,
main = FALSE, inner = TRUE, sub = FALSE,
bmar = par("mar")[1], tmar = par("mar")[3], ...,
cex.main = par("cex.main"), cex.inner = 1.2,
cex.sub = par("cex.sub"), col.points = par("col"),
col.hor = par("col"), col.vert = par("col"),
col.main = par("col.main"), col.inner = par("col.main"),
col.sub = par("col.sub"), cex.points = 2.0,
pch.u = 21, pch.a = 16, mfColRow = TRUE,
to.draw.arg = NULL, withSubst = TRUE){
mc <- match.call(call = sys.call(sys.parent(1)))
xc <- mc$x
### manipulating the ... - argument
dots <- match.call(call = sys.call(sys.parent(1)),
expand.dots = FALSE)$"..."
plotInfo <- list(call = mc, dots=dots,
args = list(width = width, height = height,
withSweave = withSweave,
xlim = xlim, ylim = ylim, verticals = verticals,
do.points = do.points, main = main, inner = inner,
sub = sub, bmar = bmar, tmar = tmar, cex.main = cex.main,
cex.inner = cex.inner, cex.sub = cex.sub,
col.points = col.points, col.hor = col.hor,
col.vert = col.vert, col.main = col.main,
col.inner = col.inner, col.sub = col.sub,
cex.points = cex.points, pch.u = pch.u,
pch.a = pch.a, mfColRow = mfColRow,
to.draw.arg = to.draw.arg, withSubst = withSubst))
to.draw <- 1:3
names(to.draw) <- c("d","p","q")
if(! is.null(to.draw.arg)){
if(is.character(to.draw.arg))
to.draw <- pmatch(to.draw.arg, names(to.draw))
else if(is.numeric(to.draw.arg))
to.draw <- to.draw.arg
}
l.draw <- length(to.draw)
pF <- expression({})
if(!is.null(dots[["panel.first"]])){
pF <- .panel.mingle(dots,"panel.first")
}
pF <- .fillList(pF, l.draw)
pL <- expression({})
if(!is.null(dots[["panel.last"]])){
pL <- .panel.mingle(dots,"panel.last")
}
pL <- .fillList(pL, l.draw)
plotInfo$to.draw <- to.draw
plotInfo$panelFirst <- pF
plotInfo$panelLast <- pL
dots$panel.first <- dots$panel.last <- NULL
dots$ngrid <- NULL
dots.for.points <- .makedotsPt(dots)
dots.lowlevel <- .makedotsLowLevel(dots)
dots.without.pch <- dots.lowlevel[! (names(dots.lowlevel) %in% c("col", "pch"))]
###
if(!is(x,"DiscreteDistribution"))
x <- .ULC.cast(x)
if(!is.logical(inner))
{if(!is.list(inner))
inner <- as.list(inner)
#stop("Argument 'inner' must either be 'logical' or a 'list'")
inner <- .fillList(inner,l.draw)
}
cex <- if (hasArg("cex")) dots$cex else 1
if (hasArg("cex") && missing(cex.points))
cex.points <- 2.0 * cex
if (hasArg("pch") && missing(pch.u))
pch.u <- dots$pch
if (hasArg("pch") && missing(pch.a))
pch.a <- dots$pch
if (hasArg("col") && missing(col.points))
col.points <- dots$col
if (hasArg("col") && missing(col.vert))
col.vert <- dots$col
if (hasArg("col") && missing(col.hor))
col.hor <- dots$col
if (hasArg("col") && missing(col.main))
col.main <- dots$col
if (hasArg("col") && missing(col.inner))
col.inner <- dots$col
if (hasArg("col") && missing(col.sub))
col.sub <- dots$col
if (!withSweave){
devNew(width = width, height = height)
}
omar <- par("mar", no.readonly = TRUE)
# omar$cin <- omar$cra <- omar$csi <- omar$cxy <- omar$din <- NULL
if(mfColRow) on.exit(par(omar, no.readonly = TRUE))
mainL <- FALSE
subL <- FALSE
lineT <- NA
logpd <- logq <- ""
## getting the parameter
slots <- slotNames(param(x))
slots <- slots[slots != "name"]
nrvalues <- length(slots)
if(nrvalues > 0){
values <- numeric(nrvalues)
for(i in 1:nrvalues)
values[i] <- attributes(attributes(x)$param)[[slots[i]]]
paramstring <- paste(values, collapse = ", ")
nparamstring <- paste(slots, "=", values, collapse = ", ")
qparamstring <- paste("(",paramstring,")",sep="")
}
else paramstring <- qparamstring <- nparamstring <- ""
.mpresubs <- if(withSubst){
function(inx)
.presubs(inx, c("%C", "%D", "%N", "%P", "%Q", "%A"),
c(as.character(class(x)[1]),
as.character(date()),
nparamstring,
paramstring,
qparamstring,
as.character(deparse(xc))))
}else function(inx) inx
xlab0 <- list("d"="x", "p"="q", "q"="p")
iL <- 1:length(to.draw)
.mp2 <- function(dlb = dots$xlab, lb0 = list("d"="x", "p"="q", "q"="p")){
dlb0 <- eval(dlb)
if (!is.null(dlb)){
.mp <- if(is.list(dlb0)) function(x,i){
if(is.call(x)) x <- eval(x)
if(length(i)==0) return(NULL)
i <- min(i)
if(is.character(x[[i]])){
return(as.character(eval(.mpresubs(x[[i]]))))
}else{
res <- .mpresubs(x[[i]])
if(length(res)==0) return(NULL)
if(is.call(res)) res <- res[-1]
return(res)}
}else function(x,i){
if(length(x)==1) return(x[1])
res <- x[i]
if(length(res)==0) return(NULL)
if(is.na(res)) return(NULL)
return(res)}
force(lb0)
.mp3 <- .mp(dlb,iL[to.draw==1])
if(1%in%to.draw & !is.null(.mp3)) lb0[["d"]] <- .mp3
.mp3 <- .mp(dlb,iL[to.draw==2])
if(2%in%to.draw & !is.null(.mp3)) lb0[["p"]] <- .mp3
.mp3 <- .mp(dlb,iL[to.draw==3])
if(3%in%to.draw & !is.null(.mp3)) lb0[["q"]] <- .mp3
}
return(lb0)}
xlab0 <- .mp2()
dots$xlab <- NULL
ylab0 <- .mp2(dlb=dots$ylab, lb0=list("d"="d(x)", "p"="p(q)", "q"="q(p)"))
dots$ylab <- NULL
if (hasArg("main")){
mainL <- TRUE
if (is.logical(main)){
if (!main) mainL <- FALSE
else
main <- gettextf("Distribution Plot for %%A") ###
### double %% as % is special for gettextf
}
main <- .mpresubs(main)
if (mainL) {
if(missing(tmar))
tmar <- 5
if(missing(cex.inner))
cex.inner <- .9
lineT <- 0.6
}
}
if (hasArg("sub")){
subL <- TRUE
if (is.logical(sub)){
if (!sub) subL <- FALSE
else sub <- gettextf("generated %%D")
### double %% as % is special for gettextf
}
sub <- .mpresubs(sub)
if (subL)
if (missing(bmar)) bmar <- 6
}
if(mfColRow)
opar <- par(mfrow = c(1,l.draw), mar = c(bmar,omar[2],tmar,omar[4]), no.readonly = TRUE)
else
opar <- par(mar = c(bmar,omar[2],tmar,omar[4]), no.readonly = TRUE)
if(is.logical(inner)){
inner.d <- if (inner)
.mpresubs(gettextf("Probability function of %%C%%Q")) else
""
inner.p <- if (inner)
.mpresubs(gettextf("CDF of %%C%%Q")) else ""
inner.q <- if (inner)
.mpresubs(gettextf("Quantile function of %%C%%Q")) else ""
### double %% as % is special for gettextf
}else{
iL <- 1:length(to.draw)
inner.d <- if(1%in%to.draw) .mpresubs(inner[[min(iL[to.draw==1])]]) else NULL
inner.p <- if(2%in%to.draw) .mpresubs(inner[[min(iL[to.draw==2])]]) else NULL
inner.q <- if(3%in%to.draw) .mpresubs(inner[[min(iL[to.draw==3])]]) else NULL
}
lower <- min(support(x))
upper <- max(support(x))
dist <- upper - lower
supp <- support(x);
if(hasArg("xlim"))
{if(length(xlim) != 2)
stop("Wrong length of Argument xlim")
supp <- supp[(supp >= xlim[1]) & (supp <= xlim[2])]
}else{
}
dx <- d(x)(supp)
if(hasArg("ylim"))
{if (3 %in% to.draw && any( c(1,2) %in% to.draw)){
if(! length(ylim) %in% c(2,4))
stop("Wrong length of Argument ylim")
}else{
if(! length(ylim) == 2)
stop("Wrong length of Argument ylim")
}
ylim <- matrix(ylim, 2,2)
ylim1 <- ylim[,1]; ylim2 <- ylim[,2];
}else{
ylim1 <- c(0, max(dx))
ylim2 <- c(-0.05,1.05)
}
if(hasArg("log"))
{logpd <- dots$log
logq <- gsub("u","y",gsub("y","x",gsub("x", "u", logpd)))
if(length(grep("y",logpd))){
ylim1 <- c(max(min(dx[dx>0]), ylim1[1]),
ylim1[2])
ylim2 <- c(max(min(dx[dx>0]), ylim2[1]),
ylim2[2])
}
}
o.warn <- getOption("warn")
options(warn = -1)
on.exit(options(warn=o.warn))
plotCount <- 1
if(1%in%to.draw){
dots.without.pch$panel.first <- pF[[plotCount]]
dots.without.pch$panel.last <- pL[[plotCount]]
plotInfo$dplot$plot <- c(list(x = supp, dx, type = "h", pch = pch.a,
ylim = ylim1, xlim=xlim, ylab = ylab0[["d"]], xlab = xlab0[["d"]],
log = logpd), dots.without.pch)
do.call(plot, c(list(x = supp, dx, type = "h", pch = pch.a,
ylim = ylim1, xlim=xlim, ylab = ylab0[["d"]], xlab = xlab0[["d"]],
log = logpd), dots.without.pch))
plotInfo$dplot$usr <- par("usr")
dots.without.pch$panel.first <- dots.without.pch$panel.last <- NULL
plotCount <- plotCount + 1
options(warn = o.warn)
title(main = inner.d, line = lineT, cex.main = cex.inner,
col.main = col.inner)
plotInfo$dplot$title <- list(main = inner.d, line = lineT,
cex.main = cex.inner, col.main = col.inner)
if(do.points){
do.call(points, c(list(x = supp, y = dx, pch = pch.a,
cex = cex.points, col = col.points), dots.for.points))
plotInfo$dplot$points <- c(list(x = supp, y = dx, pch = pch.a,
cex = cex.points, col = col.points), dots.for.points)
}
options(warn = -1)
}
ngrid <- length(supp)
supp1 <- if(ngrid>1) supp else c(-max(1,abs(supp))*.08,0)+supp
psupp1 <- c(0,p(x)(supp1))
if(2%in%to.draw){
dots.without.pch$panel.first <- pF[[plotCount]]
dots.without.pch$panel.last <- pL[[plotCount]]
plotInfo$pplot$plot <- c(list(x = stepfun(x = supp1, y = psupp1),
main = "", verticals = verticals,
do.points = FALSE,
ylim = ylim2, ylab = ylab0[["p"]], xlab = xlab0[["p"]],
col.hor = col.hor, col.vert = col.vert,
log = logpd), dots.without.pch)
do.call(plot, c(list(x = stepfun(x = supp1, y = psupp1),
main = "", verticals = verticals,
do.points = FALSE,
ylim = ylim2, ylab = ylab0[["p"]], xlab = xlab0[["p"]],
col.hor = col.hor, col.vert = col.vert,
log = logpd), dots.without.pch))
plotInfo$pplot$usr <- par("usr")
dots.without.pch$panel.first <- dots.without.pch$panel.last <- NULL
plotCount <- plotCount + 1
if(do.points)
{if(ngrid>1){
do.call(points, c(list(x = supp, y = psupp1[1:ngrid], pch = pch.u,
cex = cex.points, col = col.points), dots.for.points))
do.call(points, c(list(x = supp, y = psupp1[2:(ngrid+1)], pch = pch.a,
cex = cex.points, col = col.points), dots.for.points))
plotInfo$pplot$points.u <- c(list(x = supp, y = psupp1[1:ngrid], pch = pch.u,
cex = cex.points, col = col.points), dots.for.points)
plotInfo$pplot$points.a <- c(list(x = supp, y = psupp1[2:(ngrid+1)], pch = pch.a,
cex = cex.points, col = col.points), dots.for.points)
}else{
do.call(points, c(list(x = supp, y = 0, pch = pch.u,
cex = cex.points, col = col.points), dots.for.points))
do.call(points, c(list(x = supp, y = 1, pch = pch.a,
cex = cex.points, col = col.points), dots.for.points))
plotInfo$pplot$points.u <- c(list(x = supp, y = 0, pch = pch.u,
cex = cex.points, col = col.points), dots.for.points)
plotInfo$pplot$points.a <- c(list(x = supp, y = 1, pch = pch.a,
cex = cex.points, col = col.points), dots.for.points)
}
}
options(warn = o.warn)
title(main = inner.p, line = lineT, cex.main = cex.inner,
col.main = col.inner)
plotInfo$pplot$title <- c(main = inner.p, line = lineT,
cex.main = cex.inner, col.main = col.inner)
if(do.points){
do.call(points, c(list(x = supp,
y = c(0,p(x)(supp[-length(supp)])), pch = pch.u,
cex = cex.points, col = col.points), dots.for.points))
plotInfo$pplot$points <- c(list(x = supp,
y = c(0,p(x)(supp[-length(supp)])), pch = pch.u,
cex = cex.points, col = col.points), dots.for.points)
}
}
if(3%in%to.draw){
options(warn = -1)
dots.without.pch$panel.first <- pF[[plotCount]]
dots.without.pch$panel.last <- pL[[plotCount]]
plotInfo$qplot$plot <- c(list(x = stepfun(c(0,p(x)(supp)),
c(NA,supp,NA), right = TRUE),
main = "", xlim = ylim2, ylim = c(min(supp),max(supp)),
ylab = ylab0[["q"]], xlab = xlab0[["q"]],
verticals = verticals, do.points = do.points,
cex.points = cex.points, pch = pch.a,
col.points = col.points,
col.hor = col.hor, col.vert = col.vert,
log = logq), dots.without.pch)
do.call(plot, c(list(x = stepfun(c(0,p(x)(supp)),
c(NA,supp,NA), right = TRUE),
main = "", xlim = ylim2, ylim = c(min(supp),max(supp)),
ylab = ylab0[["q"]], xlab = xlab0[["q"]],
verticals = verticals, do.points = do.points,
cex.points = cex.points, pch = pch.a,
col.points = col.points,
col.hor = col.hor, col.vert = col.vert,
log = logq), dots.without.pch))
plotInfo$qplot$usr <- par("usr")
dots.without.pch$panel.first <- dots.without.pch$panel.last <- NULL
plotCount <- plotCount + 1
options(warn = o.warn)
title(main = inner.q, line = lineT, cex.main = cex.inner,
col.main = col.inner)
plotInfo$qplot$title <- c(main = inner.q, line = lineT,
cex.main = cex.inner, col.main = col.inner)
dots.without.pch0 <- dots.without.pch
dots.without.pch0$col <- NULL
do.call(lines, c(list(x = c(0,p(x)(supp[1])), y = rep(supp[1],2),
col = col.vert), dots.without.pch0))
plotInfo$qplot$lines <- c(list(x = c(0,p(x)(supp[1])), y = rep(supp[1],2),
col = col.vert), dots.without.pch0)
if(do.points){
do.call(points, c(list(x = p(x)(supp[-length(supp)]),
y = supp[-1], pch = pch.u, cex = cex.points,
col = col.points), dots.for.points))
do.call(points, c(list(x = 0, y = supp[1], pch = pch.u,
cex = cex.points, col = col.points), dots.for.points))
plotInfo$qplot$points.u <- c(list(x = p(x)(supp[-length(supp)]),
y = supp[-1], pch = pch.u, cex = cex.points,
col = col.points), dots.for.points)
plotInfo$qplot$points.a <- c(list(x = 0, y = supp[1], pch = pch.u,
cex = cex.points, col = col.points), dots.for.points)
}
if(verticals && ngrid>1)
{dots.without.pch0 <- dots.without.pch
dots.without.pch0$col <- NULL
do.call(lines, c(list(x = rep(p(x)(supp[1]),2), y = c(supp[1],supp[2]),
col = col.vert), dots.without.pch0))
plotInfo$qplot$vlines <- c(list(x = rep(p(x)(supp[1]),2), y = c(supp[1],supp[2]),
col = col.vert), dots.without.pch0)
}
}
if (mainL){
mtext(text = main, side = 3, cex = cex.main, adj = .5,
outer = TRUE, padj = 1.4, col = col.main)
plotInfo$mainL <- list(text = main, side = 3, cex = cex.main, adj = .5,
outer = TRUE, padj = 1.4, col = col.main)
}
if (subL){
mtext(text = sub, side = 1, cex = cex.sub, adj = .5,
outer = TRUE, line = -1.6, col = col.sub)
plotInfo$subL <- list(text = sub, side = 1, cex = cex.sub, adj = .5,
outer = TRUE, line = -1.6, col = col.sub)
}
class(plotInfo) <- c("plotInfo","DiagnInfo")
return(invisible(plotInfo))
}
)
# -------- DistributionList ---------- #
setMethod("plot", signature(x = "DistrList", y = "missing"),
function(x, ...){
mc <- as.list(match.call(call = sys.call(sys.parent(1)),
expand.dots = TRUE)[-1])
plotInfoList <- vector("list",length(x))
plotInfoList$call <- mc
for(i in 1:length(x)){
#devNew()
plotInfoList[[i]] <- plot(x[[i]],...)
}
class(plotInfoList) <- c("plotInfo","DiagnInfo")
return(invisible(plotInfoList))
})
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.