Nothing
R/graphics.R
In simsalapar: Tools for Simulation Studies in Parallel
Defines functions
mayplot
panelLegend
bgGrob
tryExpr
myHCL
myRGB
Documented in
mayplot
## Copyright (C) 2012 Marius Hofert and Martin Maechler
##
## This program is free software; you can redistribute it and/or modify it under
## the terms of the GNU General Public License as published by the Free Software
## Foundation; either version 2 of the License, or (at your option) any later
## version.
##
## This program is distributed in the hope that it will be useful, but WITHOUT
## ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
## FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
## details.
##
## You should have received a copy of the GNU General Public License along with
## this program; if not, see <http://www.gnu.org/licenses/>.
##' @title Creating Nice RGB Colors
##' @param n number of colors
##' @param cols hex values or names of colors
##' @return hex values of RGB colors
##' @author Marius Hofert
##' @note not color blind safe
myRGB <- function(n, cols=c("#FFB686", "#F083AB", "#BB65C4", "#0066CC")) # myHCL(4)
colorRampPalette(cols, space="Lab")(n) # use nice Lab space
##' @title Creating Nice HCL Colors
##' @param n number of colors
##' @param cols hex values of start and end colors
##' @return hex values of HCL colors
##' @author Marius Hofert
myHCL <- function(n, cols=c("#FFB686", "#0066CC")) {
stopifnot(length(cols)==2)
start <- rev(as(hex2RGB(cols[1]), "polarLUV")@coords) # start color
end <- rev(as(hex2RGB(cols[2]), "polarLUV")@coords) # end color
end[1] <- end[1]-360 # map correctly to not run over green
heat_hcl(n, h=c(start[1], end[1]),
c.=c(start[2], end[2]),
l=c(start[3], end[3])) # all colors on the path
}
##' for "plot math" labels {from dimnames etc}:
tryExpr <- function(ch) {
if(inherits(r <- tryCatch( parse(text=ch, srcfile=NULL),
error=function(e)e),
"error"))
ch else r
}
##' @title Compute a grob for a background with grid lines
##' @param v x-axis locations for the vertical grid lines
##' @param h y-axis locations for the horizontal grid lines
##' @param default.units default units
##' @param name name of the grob/grobTree
##' @param gp graphical parameters
##' @param vp viewport
##' @return background-with-grid-lines grob
##' @author Marius Hofert
bgGrob <- function(v, h, default.units="native", name=NULL, gp=gpar(), vp=NULL)
grobTree(rectGrob(),
segmentsGrob(v, unit(0, "npc"), v, unit(1, "npc"),
default.units=default.units),
segmentsGrob(unit(0, "npc"), h, unit(1, "npc"), h,
default.units=default.units),
name=name, gp=gp, vp=vp)
##' @title Function for constructing a \dQuote{pair} of panel function and corresponding legend grob
##' @param method panel function method (boxplot, lines, points,...); currently must be one of
##' "boxplot", "lines". Instead of "points", use "lines" with \code{type="b"}
##' @param type see lines() (for the panel function)
##' @param pch see legendGrob()
##' @param lwd line width for panel
##' @param cex (plot) character size (expansion) for panel
##' @param do.legend logical indicating if a legend should be added ....{FIXME}
##' @param leg.lwd line width for legend symbols
##' @param leg.cex size (expansion) for legend symbols and labels
##' @param leg.col legend colors
##' @param leg.expr legend labels as expressions
##' @param verbose option for marking NAs
##' @param ... additional parameters passed to the panel function
##' @author Marius Hofert
panelLegend <- function(method=c("boxplot", "lines"), type, pch,
lwd = 1, cex = 1, do.legend=TRUE,
leg.lwd = lwd, leg.cex = cex, leg.col, leg.expr,
panel.first = NULL, panel.last = NULL,
verbose=getOption("verbose"), ...)
{
## for marking NAs
markNA <- function(x.na, col) {
axis(1, at=x.na, labels=rep.int("N", length(x.na)),
mgp = c(1.5, 0.6, 0),
tick=FALSE, cex.axis=0.9, col.axis=adjustcolor(col, 0.8))
if(verbose)
message("NA's at x = ", paste(format(x.na, collapse=", ")))
}
## panel function
method <- match.arg(method)
panel <- switch(method,
"boxplot" = {
function(x, y, col, ...) {
stopifnot(is.matrix(y), (p <- length(x)) == ncol(y))
wex <- 0.5 * diff(range(x))/ p
if (!is.null(panel.first)) panel.first(x, y, col, ...)
boxplot.matrix(y, at = x, boxwex = wex, border = col,
col = NA, axes = FALSE, add = TRUE, names = FALSE,
## cex, lwd, pch: "globals" passed here:
cex = cex, lwd = lwd, pch = pch, ...)
my <- apply(y, 2, median, na.rm=TRUE)
lines(x, my, col=col, lwd=lwd) # lines
if(any(iy <- is.na(y))) { ## Mark NA's at the bottom
markNA(x[apply(iy, 2, any)], col)
}
if (!is.null(panel.last)) panel.last(x, y, col, ...)
}
},
"lines" = {
function(x, y, col, ...) {
## lines/points
if (!is.null(panel.first)) panel.first(x, y, col, ...)
lines(x, y, type=type, pch=pch, col=col, lwd=lwd, cex=cex, ...)
if(any(iy <- is.na(y))) markNA(x[iy], col) # Mark NA's at the bottom
if (!is.null(panel.last)) panel.last(x, y, col, ...)
}
},
stop(gettextf("method '%s' not yet implemented", method), domain=NA))
## legend function
lg <- if(do.legend) {
legendGrob(as.expression(leg.expr), nrow=1, pch=pch,
gp=gpar(col=leg.col, lwd=lwd, cex=cex))
## => if lwd is omitted, do.lines = FALSE => *nothing* plotted!
}
else nullGrob()
## return
list(panel=panel, legend=lg)
}
##' { end } panelLegend
##' Matrix plot with grid and gridBase, see help(mayplot) ../man/mayplot.Rd
##' { mayplot }
mayplot <- function(x, vList, row.vars = NULL, col.vars = NULL, xvar,
method = if(has.n.sim) "boxplot" else "lines",
panel.first = NULL, panel.last = NULL,
type = "l", pch = NULL, ylim = "global",
log = "", do.legend = TRUE,
spc = c(0.04/max(1,n.x-1), 0.04/max(1,n.y-1)),
axlabspc = c(0.12, 0.08), labspc = c(0.04, 0.04),
n.sim.spc = 0.06,
auxcol = c("gray40", "gray78", "gray90", "white"),
pcol = c("black", "blue", "red", "orange"), grid.lwd=1.6, ax.lwd=2,
tx.cex = 1.2, leg.cex = 1, xlab = NULL, ylab = NA,
do.n.sim = has.n.sim,
verbose = getOption("verbose"), show.layout = verbose, ...)
{
## basics ##################################################################
avar <- names( dn <- dimnames(x) ) # *a*ll variables
if(!all(avar %in% names(vList)))
stop("names(dimnames(.)) should all appear in names(vList)")
d <- dim(x)
if(!identical(avar, nd <- names(d))) {
if(!is.null(nd)) {
nonB <- nd != ""
if(any(nd[nonB] != avar[nonB]))
warning("names(dim(x)) do not match names(dimnames(x))")
}
names(d) <- avar
}
## deal with n.sim
has.n.sim <- "n.sim" %in% avar
if(has.n.sim) {
vLnsim <- vList[["n.sim"]]
if(vLnsim[["type"]] != "N")
message("\"n.sim\"'s \"type\" is not \"N\". Hopefully on purpose")
stopifnot((n.sim <- d[["n.sim"]]) == vLnsim[["value"]])
}
else if(method == "boxplot")
stop("method 'boxplot' not possible with no 'n.sim'")
## deal with boxplot case
if(method == "boxplot" && n.sim <= 4)
warning("box plots with ", n.sim, " values are rarely useful")
else if(method != "boxplot" && has.n.sim && n.sim > 1)
stop("has n.sim (= ", n.sim, ") > 1, but no boxplots.",
"\n *** error bars not yet implemented!")
## variables displayed in a single panel (different colors)
ovar <- c(xvar, col.vars, row.vars, if(has.n.sim) "n.sim") # *o*uter variables
if(!all(ovar %in% avar)) { ## error
if(!all(i <- xvar %in% avar))
stop(gettextf("'%s' entry *not* in names(dimnames(x)): \"%s\"\n",
"xvar", xvar[which(!i)[1]]), domain = NA)
if(!all(i <- col.vars %in% avar))
stop(gettextf("'%s' entry *not* in names(dimnames(x)): \"%s\"\n",
"col.vars", col.vars[which(!i)[1]]), domain = NA)
if(!all(i <- row.vars %in% avar))
stop(gettextf("'%s' entry *not* in names(dimnames(x)): \"%s\"\n",
"row.vars", row.vars[which(!i)[1]]), domain = NA)
}
v <- setdiff(avar, ovar) # variables displayed in a single panel
lv <- length(v) # number of different variables ('n', 'd',...) in a single panel
if(lv == 0) {
if(verbose) cat("no 'inner plot' variable 'v'\n")
v <- NULL
v.col <- pcol[1]
nv <- 0
} else if(lv == 1) {
nv <- length(dn[[v]]) # number of values the (single) panel plot variable 'v' takes
stopifnot(nv >= 1)
v.col <- colorRampPalette(pcol, space="Lab")(nv) # colors for v
} else stop("length(v)=", lv, " not yet implemented; too many variables (per plot panel)")
## TODO MM: great if this worked with length(v) == 2 {"n" & "d"}, and maybe > 2
## (e.g. *overplot*: one full plot for each "n" )
## => need to have accordingly many legend lines then
## permute so that we know the indices of v and outer variables (may be NULL)
avar.sort <- c(row.vars, col.vars, v, if(has.n.sim) "n.sim", xvar)
x <- aperm(x, perm = avar.sort) # permute x
## verbose
if(verbose) {
cat("xvar, col.vars, row.vars, v, n.sim : those *not* NULL are:\n")
print(c(xvar=xvar, col.vars=col.vars, row.vars=row.vars, v=v, n.sim=if(has.n.sim) n.sim))
cat("method = ", method, "; ", sep="")
stopifnot(identical(dim(x), unname(d[avar.sort])))
cat("dim(x {after aperm()}):\n"); print(d[avar.sort])
}
## z = value of xvar or seq_along() of it
xv <- vList[[xvar]]$value # *x* axis *v*alue
z <- if(is.character(xv) || is.recursive(xv)) seq_along(xv)
else {
z <- tryCatch(as.numeric(xv), error=function(e) e)
if(inherits(z, "error")) seq_along(xv) else z
}
zrange <- range(z) # for forcing the same x axis limits per row
if(method=="boxplot") zrange <- extendrange(zrange)
## ylim
ylim.msg <- "'ylim' must be \"global\", \"local\", or numeric of length two"
if(is.character(ylim)) {
ylim <- match.arg(ylim, c("global", "local"))
do.ylim <- ylim == "local"
if(!do.ylim) ylim <- range(x, na.rm=TRUE)
} else if(is.numeric(ylim)) {
do.ylim <- FALSE
if(!(length(ylim) == 2 && is.finite(ylim)))
stop(ylim.msg)
} else stop(ylim.msg)
do.legend <- do.legend && lv
## number of column/row variables
getdn <- function(nm) if(is.null(nm)) nm else dn[[nm]] # get dim names
nx <- length(getdn(col.vars)) # number of column variables
ny <- length(getdn(row.vars)) # number of row variables
## adjust for degenerate case
n.x <- max(1, nx) # number of columns to plot
n.y <- max(1, ny) # number of rows to plot
## panel (function) *and* legend (grob) ####################################
check.panel <- function(p)
is.function(p) && length(ff <- formals(p)) >= 3 &&
all(c("y", "col") %in% names(ff[-1])) # all but first must match
## construct default panel function with matching legend
if(is.null(pch)) pch <- if(type %in% c("p","o","b")) 1 # else NULL; pch from legendGrob()
## note: nv can be 0 in which case lexpr == list() [still works]
lexpr <- lapply(seq_len(nv), function(k)
substitute(expr == val,
list(expr=vList[[v]][["expr"]],
val=dn[[v]][k]))) # legend symbols and labels
pl <- panelLegend(method=method, type=type, pch=pch,
do.legend=do.legend,
leg.col=v.col, leg.expr=lexpr,
panel.first=panel.first, panel.last=panel.last,
verbose=verbose, leg.cex=leg.cex, ...)
## panel
panel <- pl$panel
stopifnot(check.panel(panel))
## legend
if(do.legend) {
legend.grob <- pl$legend
legspc <- 0.03 ### FIXME from grob! (and test with cex=0.5 or 2,etc)
}
stopifnot(length(spc) == 2, length(axlabspc) == 2,
length(labspc) == 2, length(auxcol) == 4)
## number of columns/rows in the layout
## for y axis label; (nx-1)* (plot+gaps); plot; row.vars labels :
## space for 1 (of n.x) plot in x direction:
w.all <- (axlabspc[1] + labspc[1] + n.sim.spc + (n.x-1)*spc[1])
if(w.all >= 1) stop("Choose smaller 'axlabspc[1]', 'labspc[1]', 'spc[1]', 'n.sim.spc'")
Pxsp <- (1 - w.all) / n.x
wid.gl <- c(axlabspc[1], # y axis label
rep(c(Pxsp, spc[1]), n.x-1), Pxsp, # panels (+ horizontal space in between)
labspc[1], # panel labels
if(has.n.sim) n.sim.spc) # if n.sim, 'second y axis' label
nx. <- length(wid.gl) # number of columns in the layout
## for col.vars labels; (ny-1)*(plot+gap); plot;
## space for 1 (of n.y) plot in y direction:
leg.spc <- if(do.legend) legspc else 0
h.all <- (labspc[2] + axlabspc[2] + leg.spc + (n.y-1)*spc[2])
if(h.all >= 1) stop("Choose smaller 'xlabspc[2]', 'labspc[2]', 'spc[2]', 'legspc'")
Pysp <- (1 - h.all) / n.y
hei.gl <- c(labspc[2], # panel labels
rep(c(Pysp, spc[2]), n.y-1), Pysp, # panels (+ vertical space in between)
axlabspc[2], # x axis label
if(do.legend) leg.spc) # legend
ny. <- length(hei.gl) # number of rows in the layout
## layout via grid #########################################################
## plot settings, restored on exit
opar <- par(no.readonly=TRUE); on.exit(par(opar))
plot.new() # start (empty) new page with 'graphics'; grid.newpage() fails here
## TODO MM: use smart units for widths/heights rather than just 'npc'
gl <- grid.layout(nrow=ny., ncol=nx., widths=wid.gl, heights=hei.gl,
## units in npc as for pdf()
## (no square plotting region otherwise)
default.units="npc")
if(show.layout) grid.show.layout(gl, vp=viewport(width=1.25, height=1.25))
pushViewport(viewport(layout=gl)) # use this layout in a viewport
## drawback of working with base graphics: layout has to be fully
## specified before plotting
## plot data ###############################################################
## walk over rows
for(i in 1:n.y)
{
i. <- 2*i # column index in layout (for jumping over gaps)
if(verbose) cat(sprintf("plot row %d (%d): [columns:] ", i, i.))
## pick out data to plot
xi <- # x for a fixed 'i'
if(ny) switch(length(d),
x[i ,drop=FALSE],
x[i , ,drop=FALSE],
x[i ,, ,drop=FALSE],
x[i ,,, ,drop=FALSE],
x[i ,,,, ,drop=FALSE],
stop(gettextf("'x' has wrong rank = length(dim(x)) = %d",
length(d))))
else x
if(do.ylim) ylim <- range(xi, na.rm=TRUE) # forcing same y axis limits per row
## walk over columns
for(j in 1:n.x)
{
j. <- 2*j # row index in layout (for jumping over gaps)
if(verbose) cat(sprintf("%d (%d) ", j, j.))
## push viewport
pushViewport(viewport(layout.pos.row=i., layout.pos.col=j.))
## plot panels #####################################################
## start a base graphics plot
par(plt=gridPLT(), new=TRUE) # Paul: always do this before each new base graphics plot
## set up coordinate system
plot.window(zrange, ylim, log=log)
## setup for background grid
## former base-graphics grid:
## grid.rect(gp=gpar(col=NA, fill=auxcol[3]))
## grid(col=auxcol[4], lty="solid", lwd=grid.lwd, equilogs=FALSE)
pxlog <- par("xlog")
pylog <- par("ylog")
v <- axTicks(1, axp=par("xaxp"), log=pxlog) # x values of vertical lines
h <- axTicks(2, axp=par("yaxp"), log=pylog) # y values of horizontal lines
if(pxlog) v <- log10(v)
if(pylog) h <- log10(h)
## => v, h have to be determined *here* [not in bgGrob()]
usr <- par("usr")
## background
grid.draw(bgGrob(v=v, h=h, vp=viewport(xscale=usr[1:2], yscale=usr[3:4]),
gp=gpar(col=auxcol[4], fill=auxcol[3])))
## panel
nxy <- nx && ny # TRUE <=> there is at least one row and one column
if(lv) {
for(k in 1:nv) {# walk over all variables plotted in a single panel
## y values
y. <- switch(length(d)-2, # length(ovar)-1 - has.n.sim,
if(nxy) xi[1,j,k] else if(ny) xi[1,,k] else xi[j,,k],
if(nxy) xi[1,j,k,] else if(ny) xi[1,,k,] else xi[j,,k,],
if(nxy) xi[1,j,k,,] else if(ny) xi[1,,k,,] else xi[j,,k,,],
stop("wrong length(ovar)"))
## panel
panel(z, y=y., col=v.col[k], ...)
}
} else { # no v (still n.sim or not)
## y values
y. <- switch(length(d)-1, # length(ovar) - has.n.sim,
if(nxy) xi[1,j] else if(ny) xi[1,] else xi[j,],
if(nxy) xi[1,j,] else if(ny) xi[1,,] else xi[j,,],
if(nxy) xi[1,j,,] else if(ny) xi[1,,,] else xi[j,,,],
stop("wrong length(ovar)"))
## panel
panel(z, y=y., col=v.col, ...)
}
## axes ############################################################
c.ax <- auxcol[1]
## x axis
if(i == n.y)
{
if(is.character(xv))
axis(1, at=z, labels=xv,
lwd=ax.lwd, col=NA, col.ticks=c.ax, col.axis=c.ax)
else
axis(1, lwd=ax.lwd, col=NA, col.ticks=c.ax, col.axis=c.ax)
if(is.null(xlab)) xlab <- vList[[xvar]]$expr
if(!identical(xlab, NA)) { # x axis label
## would need "with local viewport": but the push..()/up..()
## does not work WHY ???
## pushViewport(viewport(layout.pos.row=ny., layout.pos.col=j.))
## grid.text(xlab, x=1, y=0.9, # check.overlap=TRUE,
## gp = gpar(col = c.ax))
## popViewport()
## Using traditional graphics instead:
## mtext(xlab, side=1, at=zrange[2], col = c.ax, adj=c(0,0))
## ... TODO MM ... use grid! This *IS* ugly
## draw it between the last two tick marks :
axt <- axTicks(1)
at <- mean(axt[-1:0 + length(axt)])
mtext(xlab, side=1, at=at, col = c.ax, font = 2)#, adj=0.5
## draw axis arrow '-->' above the xlab:
## pu <- par("usr"); if(par("xlog")) pu[1:2] <- 10^pu[1:2]
## x0 <- pu[2] + (pu[2]-pu[1])
## x1 <- x0 + (x0 - pu[1])* spc[1]/Pxsp/2
## y0 <- pu[3]; if(par("ylog")) y0 <- 10^y0
## arrows(x0=x0, y0=y0, x1=x1, length=1/8, col = c.ax, xpd=NA)
}
}
## y axis
if(j == 1)
{
at <- axisTicks(par("usr")[3:4], log=par("ylog"))
if(packageVersion("sfsmisc") >= "1.0-21")
## allow for adjusting colors of small ticks
eaxis(2, at=at, lwd=ax.lwd, col=NA, col.ticks=c.ax, col.axis=c.ax, las = 1,
small.args=list(col=NA, col.ticks=c.ax, col.axis=c.ax))
else
eaxis(2, at=at, lwd=ax.lwd, col=NA, col.ticks=c.ax, col.axis=c.ax, las = 1)
}
popViewport()
## panel labels ####################################################
## column (col.vars) panel labels
if(i == 1 && !is.null(col.vars)) {
pushViewport(viewport(layout.pos.row=1, layout.pos.col=j.))
grid.rect(gp=gpar(col=NA, fill=auxcol[2]))
grid.text(tryExpr(dn[[col.vars]][j]), x=0.5, y=0.5, gp=gpar(cex=tx.cex))
popViewport()
}
## row (row.vars) panel labels
if(j == n.x && !is.null(row.vars)) {
pushViewport(viewport(layout.pos.row=i.,
layout.pos.col=if(has.n.sim) nx.-1 else nx.))
grid.rect(gp=gpar(col=NA, fill=auxcol[2]))
grid.text(tryExpr(dn[[row.vars]][i]), x=0.5, y=0.5, gp=gpar(cex=tx.cex),
rot=-90)
popViewport()
}
} # for(j ..)
if(verbose) cat("\n")
} # for(i ..)
## additionals #############################################################
## ylab
if(!identical(ylab, NA)) { # may be language where is.na(.) warns
max.row <- if(lv) ny.-2 else ny.-1
stopifnot(max.row >= 2) # defensive programming
## main
pushViewport(viewport(layout.pos.row=2:max.row, layout.pos.col=1))
grid.text(ylab, x=unit(0.6, "lines"), just=c("left", "centre"), rot=90)
popViewport()
}
## ylab2 (n.sim)
if(has.n.sim && do.n.sim) {
max.row <- if(lv) ny.-2 else ny.-1
stopifnot(max.row >= 2) # defensive programming
## main
pushViewport(viewport(layout.pos.row=2:max.row, layout.pos.col=nx.))
## note: vLnsim = vList[["n.sim"]] (which is defined if has.n.sim)
lab <- substitute(lab == val, list(lab=vLnsim[["expr"]], val=vLnsim[["value"]]))
grid.text(lab, y=unit(0, "npc"), # placing it at last/bottom panel(s)
just=c("left", "centre"), # given that point, use this (x, y) adjustment
rot=90, gp=gpar(cex=leg.cex))
popViewport()
}
## legend (for all variables appearing in a single panel)
if(do.legend)
{
## main
wran <- if(has.n.sim) 2:(nx.-2) else 2:(nx.-1) # width range
pushViewport(viewport(layout.pos.row=ny., layout.pos.col=wran))
grid.draw(legend.grob)
popViewport()
}
invisible(gl)
}
##' { end } mayplot
## ### pure grid (+lattice)
## if(FALSE) {##============ mayplotGrob() not yet ===================================
## ## From R-help (19 March 2010), by Baptiste Auguie
## latticeGrob <- function(x, ...) grob(.p. = x, cl="lattice", ...)
## ## ---
## ##' when grid.draw() does its battery of things, drawDetails() is one of them:
## drawDetails.lattice <- function(x, recording=FALSE) {
## lattice:::plot.trellis(x$.p., newpage=FALSE)
## ## ---
## }
## mayplotGrob <- function(x, vList, row.vars, col.vars, xvar, log = "",
## panelGrob = NULL,
## spc = c(0.04/max(1,n.x-1), 0.04/max(1,n.y-1)),
## auxcol = c("gray40", "gray78", "gray90", "white"),
## pcol = c("blue", "red", "orange"),
## xlab = NULL, ylab = NULL,
## ylim = "global", type = "l",
## doBoxp = has.n.sim,
## verbose = getOption("verbose"),
## vp.ex = 1, draw=TRUE, ...)
## {
## stopifnot(require("lattice"))
## ## auxiliary function for building names
## getName <- function(x) vapply(x, `[[`, "", "name")
## ## basics
## if(missing(row.vars)) row.vars <- NULL
## if(missing(col.vars)) col.vars <- NULL
## namD <- names( dn <- dimnames(x) )
## if(!all(namD %in% names(vList)))
## stop("names(dimnames(.)) should all appear in names(vList)")
## d <- dim(x)
## if(is.null(names(d))) names(d) <- namD else stopifnot(names(d) == namD)
## has.n.sim <- "n.sim" %in% namD
## if(has.n.sim) {
## vLnsim <- vList[["n.sim"]]
## stopifnot(vLnsim[["type"]] == "N",
## (n.sim <- d[["n.sim"]]) == vLnsim[["value"]])
## }
## else if(doBoxp) stop("no 'n.sim' -- doBoxp=TRUE is not possible")
## ## the variable displayed in one plot (with different colors):
## ovar <- c(xvar, col.vars, row.vars, if(has.n.sim) "n.sim")
## v <- setdiff(namD, ovar)
## ## TODO MM: great if this worked with length(v) == 2 {"n" & "d"}, and maybe > 2
## ## (e.g. *overplot*: one full plot for each "n" )
## if(doBoxp && n.sim <= 4)
## warning("box plots with ",n.sim," values are rarely useful")
## else if(!doBoxp && has.n.sim && n.sim > 1)
## stop("has n.sim (= ",n.sim,") > 1, but no boxplots.",
## "\n *** error bars not yet implemented!")
## if((lv <- length(v)) > 1)
## stop("length(v)=",lv," not yet implemented; too many variables (per plot panel)")
## if(lv == 0) {
## if(verbose) cat("no 'inner plot' variable 'v'\n")
## v <- NULL
## v.col <- pcol[1]
## } else { ## (lv >= 1)
## stopifnot(1 <= (nv <- length(dn[[v]])))
## ## if(nv > length(pcol))# not an error; can still work!
## ## warning("less colors in 'pcol' than values in ",v,
## ## " (", length(pcol)," < ", nv,")")
## v.col <- colorRampPalette(pcol, space="Lab")(nv) # colors for v
## }
## ## permute to know the component indices (v and others may be NULL !):
## p.x <- c(row.vars, col.vars, v, if(has.n.sim) "n.sim", xvar)
## x <- aperm(x, perm = p.x)
## if(verbose) {
## cat("xvar, col.vars, row.vars, v, n.sim : those *not* NULL are:\n")
## print(c(xvar=xvar, col.vars=col.vars,
## row.vars=row.vars, v=v, n.sim=if(has.n.sim) n.sim))
## if(is.null(panelGrob)) cat("doBoxp= ",doBoxp,"; ", sep="")
## stopifnot(identical(dim(x), unname(d[p.x])))
## cat("dim(x {after aperm()}):\n"); print(d[p.x])
## }
## if(is.null(xlab)) # default: the expression from varlist
## xlab <- vList[[xvar]]$expr
## xv <- vList[[xvar]]$value
## z <- if(is.character(xv) || is.recursive(xv)) seq_along(xv) else {
## z <- tryCatch(as.numeric(xv), error=function(e)e)
## if(inherits(z, "error")) seq_along(xv) else z
## }
## zrange <- range(z) # for forcing the same x axis limits per row
## if(doBoxp) zrange <- extendrange(zrange)
## if(is.null(panelGrob)) {
## markNA <- function(x.na, col) {
## ## FIXME this is still base-graphics
## xaxisGrob(1, at=x.na, labels=rep.int("N", length(x.na)),
## mgp = c(1.5, 0.6, 0),
## tick=FALSE, cex.axis=0.9, col.axis=adjustcolor(col, 0.8))
## if(verbose)
## message("NA's at x = ", paste(format(x.na, collapse=", ")))
## }
## panelGrob <-
## if(doBoxp)
## function(z, y, col, nv, ...) {
## stopifnot(is.matrix(y), (p <- length(z)) == ncol(y))
## stop("doBoxp not yet implemented here")
## wex <- 0.5 * diff(range(z))/ p
## boxplot.matrix(y, at = z, boxwex = wex, col=NA, border = col,
## axes=FALSE, add=TRUE, names=FALSE, ...)
## my <- apply(y, 2, median, na.rm=TRUE)
## lines(z, my, col=col) # <- not yet '...' (warnings)
## if(any(iy <- is.na(y))) { ## Mark NA's at the bottom
## markNA(z[apply(iy, 2, any)], col)
## }
## }
## else
## function(z, y, col, nv, ...) {
## ## plot corresponding points/lines
## lg <- linesGrob(z, y, type=type, col=col, ...)
## if(any(iy <- is.na(y))) { ## Mark NA's at the bottom
## markNA(z[iy], col)
## }
## }
## ## Workaround for now
## panelGrob <- function(z, y, col, nv, ...)
## rectGrob(gp = gpar(fill = "tomato")) # TODO for now!
## }
## else stopifnot(is.function(panelGrob),
## length(ff <- formals(panelGrob)) >= 4,
## ## the first argument can be named arbitrarily; the others must match:
## c("y", "col","nv") %in% names(ff[-1]))
## ylim.msg <- "'ylim' must be \"global\", \"local\", or numeric of length two"
## if(is.character(ylim)) {
## ylim <- match.arg(ylim, c("global", "local"))
## do.ylim <- ylim == "local"
## if(!do.ylim) ylim <- range(x, na.rm=TRUE)
## } else if(is.numeric(ylim)) {
## do.ylim <- FALSE
## if(!(length(ylim) == 2 && is.finite(ylim)))
## stop(ylim.msg)
## } else stop(ylim.msg)
## ## set up the grid layout
## getdn <- function(nm) if(is.null(nm)) nm else dn[[nm]]
## nx <- length(getdn(col.vars)) # number of plot columns
## ny <- length(getdn(row.vars)) # number of plot rows
## n.y <- max(1, ny)
## n.x <- max(1, nx)
## stopifnot(length(spc) == 2)
## ## build matrix structure
## ## basic matrix layout for panels
## res <- gtable(widths =unit(rep(1, n.x), "null"),
## heights=unit(rep(1, n.y), "null"))
## ## gmat <- gtable(## +1: add 1 column at the right border for 'row.var's:
## ## widths = unit(rep(1, n.x + 1), "null"),
## ## ## +1: add 1 row at the top border for 'col.var's:
## ## heights = unit(rep(1, n.y + 1), "null"))
## ###=========== WORK FROM HERE ========================================
## ## panels ##################################################################
## npanel <- function(ji)
## {
## i <- ji[2]
## xi <-
## if(ny) switch(length(d),
## x[i ,drop=FALSE],
## x[i , ,drop=FALSE],
## x[i ,, ,drop=FALSE],
## x[i ,,, ,drop=FALSE],
## x[i ,,,, ,drop=FALSE],
## stop(gettextf("'x' has wrong rank = length(dim(x)) = %d",
## length(d))))
## else x
## j <- ji[1]
## if(do.ylim)
## ylim <- range(xi, na.rm=TRUE) # for forcing the same y axis limits per row
## ## j. <- 2*j # row index in layout (for jumping over gaps)
## if(verbose) cat(sprintf("%d (%d) ", j))#, j.))
## ## prelim stuff
## ch <- paste0("panel (", io, ",", j, ")")
## nxy <- nx && ny
## if(lv) {
## ## FIXME: for(k in 1:nv)
## warning("nv=",nv, "; we are only drawing the first")
## k <- 1
## x. <- ## panel(z, y=
## switch(length(d)-2, #length(ovar)-1 -has.n.sim,
## if(nxy) xi[1,j,k] else if(ny) xi[1,,k] else xi[j,,k],
## if(nxy) xi[1,j,k,] else if(ny) xi[1,,k,] else xi[j,,k,],
## if(nxy) xi[1,j,k,,] else if(ny) xi[1,,k,,] else xi[j,,k,,],
## stop("wrong length(ovar)"))
## ## ,
## ## col = v.col[k], nv=nv, ...)
## } else # no 'v'; (still n.sim or not)
## x. <- ## panel(z, y=
## switch(length(d)-1, #length(ovar) -has.n.sim,
## if(nxy) xi[1,j] else if(ny) xi[1,] else xi[j,],
## if(nxy) xi[1,j,] else if(ny) xi[1,,] else xi[j,,],
## if(nxy) xi[1,j,,] else if(ny) xi[1,,,] else xi[j,,,],
## stop("wrong length(ovar)"))
## ## ,
## ## col = v.col, nv=0, ...)
## ## r.x <- length(dx <- dim(x))
## ## if(r.x == 5)
## ## x. <- x[i,j,,1,1] # points (for fixed 'tau', 'family'; additionally, we fix 'n' and 'd' here)
## ## else if(r.x == 4)
## ## x. <- x[i,j,1, ] # points ...
## ## else if(r.x == 3)
## ## x. <- x[i,j, ] # points ...
## ## else stop("silly panel not yet working for length(dim(x)) = ", r.x)
## ## plot x. (in alpha for each d)
## #z <- c(0.9, 0.95, 0.99, 0.999)
## xyscales <- list(y=list(log=TRUE, equispaced.log = FALSE),
## draw = FALSE)
## xy <- xyplot(x. ~ z, ## 2^(11:30)~11:30,
## scales= xyscales)
## gxy <- latticeGrob(xy, name="xy-grob")
## gTree(rectGrob(gp=gpar(fill=auxcol[3])), # background
## ## __TODO__: plot.window(zrange, ylim, log=log)
## ## gridGrob(.........)
## ## grid(col=auxcol[4], lty="solid", lwd=grid.lwd, equilogs=FALSE)
## if(verbose) textGrob(label=paste("Hi, I'm", ch)),
## if(FALSE)
## linesGrob(x = z,#c(0.9, 0.95, 0.99, 0.999),
## y = x.,
## default.units = "native",
## vp = dataViewport(z, x.)),
## gxy,
## name=ch)
## }
## ## construct panels
## ji.mat <- expand.grid(col=seq_len(n.x), row=seq_len(n.y),
## KEEP.OUT.ATTRS = FALSE)
## panels <- apply(ji.mat, 1, npanel) # compute panels
## ## add panels to plot (~> existing layout)
## ## (t, l): = (top,left)-positions (usual matrix index) in the layout;
## ## see res$layout and source of gtable_add_grob
## res <- gtable_add_grob(res, grobs=panels,
## t = ji.mat[,2], # 1, ..., 1, 2, ..., 2, n.y, ..., n.y
## l = ji.mat[,1], # 1, 2, ..., n.x, 1, 2, ..., n.x
## name=getName(panels))
## ## ## for y axis label; (nx-1)* (plot+gaps); plot; row.vars labels :
## ## ## space for 1 (of n.x) plot in x direction:
## ## Pxsp <- (1 - (axlabspc[1] + labspc[1]+ (n.x-1)*spc[1]))/ n.x
## ## wid.gl <- c(axlabspc[1], rep(c(Pxsp, spc[1]), n.x-1), Pxsp, labspc[1])
## ## ## for col.vars labels; (ny-1)*(plot+gap); plot; if(lv): {legend for v}
## ## ## space for 1 (of n.y) plot in y direction:
## ## leg.sp <- if(lv) legspc else 0
## ## Pysp <- (1 - (labspc[2]+ axlabspc[2]+ leg.sp + (n.y-1)*spc[2]))/ n.y
## ## hei.gl <- c(labspc[2], rep(c(Pysp, spc[2]), n.y-1), Pysp, axlabspc[2],
## ## if(lv) leg.sp)
## ## nx. <- length(wid.gl)
## ## ny. <- length(hei.gl)
## ## ## plot settings, restored on exit
## ## opar <- par(no.readonly=TRUE); on.exit(par(opar))
## ## plot.new() # start (empty) new page with 'graphics'
## ## ## TODO MM: use smart units for widths/heights rather than just 'npc'
## ## gl <- grid.layout(nrow=ny., ncol=nx., widths= wid.gl, heights = hei.gl,
## ## ## units in npc as for pdf(); no square plotting region otherwise:
## ## default.units="npc")
## ## if(show.layout) grid.show.layout(gl, vp=viewport(width=1.25, height=1.25))
## ## pushViewport(viewport(layout=gl)) # use this layout in a viewport
## ###---- currently "muted":
## if(FALSE)
## ## --- plot data ---
## for(i in 1:n.y) { # rows
## ## i. <- 2*i # column index in layout (for jumping over gaps)
## if(verbose) cat(sprintf("plot row %d (%d): [columns:] ", i))#, i.))
## xi <-
## if(ny) switch(length(d),
## x[i ,drop=FALSE],
## x[i , ,drop=FALSE],
## x[i ,, ,drop=FALSE],
## x[i ,,, ,drop=FALSE],
## x[i ,,,, ,drop=FALSE],
## stop(gettextf("'x' has wrong rank = length(dim(x)) = %d",
## length(d))))
## else x
## if(do.ylim)
## ylim <- range(xi, na.rm=TRUE) # for forcing the same y axis limits per row
## for(j in 1:n.x) { # columns
## ## j. <- 2*j # row index in layout (for jumping over gaps)
## if(verbose) cat(sprintf("%d (%d) ", j))#, j.))
## ## pushViewport(viewport(layout.pos.row=i., layout.pos.col=j.))
## ## plot
## ## grid.rect(gp=gpar(col=NA, fill=auxcol[3])) # background
## ## ## start a 'graphics' plot
## ## par(plt = gridPLT())
## ## par(new=TRUE) # always do this before each new 'graphics' plot
## ## ## set up coordinate system:
## ## plot.window(zrange, ylim, log=log)
## ## ## background grid:
## ## grid(col=auxcol[4], lty="solid", lwd=grid.lwd, equilogs=FALSE)
## nxy <- nx && ny
## if(lv) for(k in 1:nv)
## panel(z, y=
## switch(length(d)-2, #length(ovar)-1 -has.n.sim,
## if(nxy) xi[1,j,k] else if(ny) xi[1,,k] else xi[j,,k],
## if(nxy) xi[1,j,k,] else if(ny) xi[1,,k,] else xi[j,,k,],
## if(nxy) xi[1,j,k,,] else if(ny) xi[1,,k,,] else xi[j,,k,,],
## stop("wrong length(ovar)"))
## ,
## col = v.col[k], nv=nv, ...)
## else # no 'v'; (still n.sim or not)
## panel(z, y=
## switch(length(d)-1, #length(ovar) -has.n.sim,
## if(nxy) xi[1,j] else if(ny) xi[1,] else xi[j,],
## if(nxy) xi[1,j,] else if(ny) xi[1,,] else xi[j,,],
## if(nxy) xi[1,j,,] else if(ny) xi[1,,,] else xi[j,,,],
## stop("wrong length(ovar)"))
## ,
## col = v.col, nv=0, ...)
## ## axes
## c.ax <- auxcol[1]
## if(i == n.y) { # x axis
## if(is.character(xv))
## axis(1, at=z, labels=xv,
## lwd=ax.lwd, col=NA, col.ticks=c.ax, col.axis=c.ax)
## else
## axis(1, lwd=ax.lwd, col=NA, col.ticks=c.ax, col.axis=c.ax)
## if(!is.null(xlab) && !identical(xlab, NA)) { ## x axis label
## ## would need "with local viewport": but the push..()/up..()
## ## does not work WHY ???
## ## pushViewport(viewport(layout.pos.row=ny., layout.pos.col=j.))
## ## grid.text(xlab, x=1, y=0.9, # check.overlap=TRUE,
## ## gp = gpar(col = c.ax))
## ## popViewport()
## ## Using traditional graphics instead:
## ## mtext(xlab, side=1, at=zrange[2], col = c.ax, adj=c(0,0))
## ## ... TODO MM ... use grid! This *IS* ugly
## ## draw it between the last two tick marks :
## axt <- axTicks(1)
## at <- mean(axt[-1:0 + length(axt)])
## mtext(xlab, side=1, at=at, col = c.ax, font = 2)#, adj=0.5
## ## draw axis arrow '-->' above the xlab:
## ## pu <- par("usr"); if(par("xlog")) pu[1:2] <- 10^pu[1:2]
## ## x0 <- pu[2] + (pu[2]-pu[1])
## ## x1 <- x0 + (x0 - pu[1])* spc[1]/Pxsp/2
## ## y0 <- pu[3]; if(par("ylog")) y0 <- 10^y0
## ## arrows(x0=x0, y0=y0, x1=x1, length=1/8, col = c.ax, xpd=NA)
## }
## }
## if(j == 1) { # y axis
## at <- axisTicks(par("usr")[3:4], log=par("ylog"))
## if(packageVersion("sfsmisc") >= "1.0-21")
## ## allow for adjusting colors of small ticks
## eaxis(2, at=at, lwd=ax.lwd, col=NA, col.ticks=c.ax, col.axis=c.ax,
## las = ylas,
## small.args=list(col=NA, col.ticks=c.ax, col.axis=c.ax))
## else
## eaxis(2, at=at, lwd=ax.lwd, col=NA, col.ticks=c.ax, col.axis=c.ax,
## las = ylas)
## }
## popViewport()
## ## column labels (col.vars)
## if(i == 1 && !is.null(col.vars)) {
## pushViewport(viewport(layout.pos.row=1, layout.pos.col=j.))
## grid.rect(gp=gpar(col=NA, fill=auxcol[2]))
## grid.text(tryExpr(dn[[col.vars]][j]), x=0.5, y=0.5, gp=gpar(cex=tx.cex))
## popViewport()
## }
## ## row labels (row.vars)
## if(j == n.x && !is.null(row.vars)) {
## pushViewport(viewport(layout.pos.row=i., layout.pos.col=nx.))
## grid.rect(gp=gpar(col=NA, fill=auxcol[2]))
## grid.text(tryExpr(dn[[row.vars]][i]), x=0.5, y=0.5, gp=gpar(cex=tx.cex),
## rot=-90)
## popViewport()
## }
## }## for(j ..)
## if(verbose) cat("\n")
## }## for(i ..)
## ###---- currently "muted"
## ## panel labels ############################################################
## panelLabs <- function(i, rot=0, base.name=if(rot) "row" else "col")
## gTree(rectGrob(gp=gpar(fill="gray50")),
## textGrob(label=paste(base.name, "lab", i), rot=rot),
## name=paste("label", base.name, i))
## col.pLabs <- lapply(seq_len(n.x), panelLabs) # list of col panel label grobs
## row.pLabs <- lapply(seq_len(n.y), panelLabs, rot=-90) # list of row panel label grobs
## ## add col panel labels
## ## layout for col panel labels: pos = 0: on top
## res <- gtable_add_rows(res, heights=2*grobHeight(textGrob("X")), pos=0)
## res <- gtable_add_grob(res, grobs=col.pLabs, t=1, l=seq_len(n.x),
## name=getName(col.pLabs)) # fill in labels
## ## add row panel labels
## ## layout for row panel labels (pos = default): at "end", i.e., bottom:
## res <- gtable_add_cols(res, widths=2*grobHeight(textGrob("X")))
## res <- gtable_add_grob(res, grobs=row.pLabs, t=1+seq_len(n.y), l=n.x+1,
## name=getName(row.pLabs)) # fill in labels
## ## note: the t=1+... is due to the fact that we already added a row on top of the basic layout
## ## inter-row and -column space #############################################
## as.unit <- function(x) if(is.unit(x)) x else unit(x, "npc")
## spc <- as.unit(spc)
## for(i in rev(1L +seq_len(n.y-1L)))# "1+" already have top "col lab" labels
## res <- gtable_add_rows(res, heights= spc[2], pos=i) # row space
## for(j in rev(seq_len(n.x-1L)))
## res <- gtable_add_cols(res, widths = spc[1], pos=j) # col space
## ## labels ##################################################################
## res <- gtable_add_cols(res, widths =2*grobHeight(textGrob("X")))
## res <- gtable_add_rows(res, heights=2*grobHeight(textGrob("X")))
## ## TODO continue... (with filling in labels)
## if(draw) grid.draw(res)
## ## return
## invisible(res)
## }
## }##============ mayplotGrob() not yet ===================================
Try the simsalapar package in your browser
Any scripts or data that you put into this service are public.
simsalapar documentation built on April 27, 2023, 9:05 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions mayplot panelLegend bgGrob tryExpr myHCL myRGB
Documented in mayplot
## Copyright (C) 2012 Marius Hofert and Martin Maechler
##
## This program is free software; you can redistribute it and/or modify it under
## the terms of the GNU General Public License as published by the Free Software
## Foundation; either version 2 of the License, or (at your option) any later
## version.
##
## This program is distributed in the hope that it will be useful, but WITHOUT
## ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
## FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
## details.
##
## You should have received a copy of the GNU General Public License along with
## this program; if not, see <http://www.gnu.org/licenses/>.
##' @title Creating Nice RGB Colors
##' @param n number of colors
##' @param cols hex values or names of colors
##' @return hex values of RGB colors
##' @author Marius Hofert
##' @note not color blind safe
myRGB <- function(n, cols=c("#FFB686", "#F083AB", "#BB65C4", "#0066CC")) # myHCL(4)
colorRampPalette(cols, space="Lab")(n) # use nice Lab space
##' @title Creating Nice HCL Colors
##' @param n number of colors
##' @param cols hex values of start and end colors
##' @return hex values of HCL colors
##' @author Marius Hofert
myHCL <- function(n, cols=c("#FFB686", "#0066CC")) {
stopifnot(length(cols)==2)
start <- rev(as(hex2RGB(cols[1]), "polarLUV")@coords) # start color
end <- rev(as(hex2RGB(cols[2]), "polarLUV")@coords) # end color
end[1] <- end[1]-360 # map correctly to not run over green
heat_hcl(n, h=c(start[1], end[1]),
c.=c(start[2], end[2]),
l=c(start[3], end[3])) # all colors on the path
}
##' for "plot math" labels {from dimnames etc}:
tryExpr <- function(ch) {
if(inherits(r <- tryCatch( parse(text=ch, srcfile=NULL),
error=function(e)e),
"error"))
ch else r
}
##' @title Compute a grob for a background with grid lines
##' @param v x-axis locations for the vertical grid lines
##' @param h y-axis locations for the horizontal grid lines
##' @param default.units default units
##' @param name name of the grob/grobTree
##' @param gp graphical parameters
##' @param vp viewport
##' @return background-with-grid-lines grob
##' @author Marius Hofert
bgGrob <- function(v, h, default.units="native", name=NULL, gp=gpar(), vp=NULL)
grobTree(rectGrob(),
segmentsGrob(v, unit(0, "npc"), v, unit(1, "npc"),
default.units=default.units),
segmentsGrob(unit(0, "npc"), h, unit(1, "npc"), h,
default.units=default.units),
name=name, gp=gp, vp=vp)
##' @title Function for constructing a \dQuote{pair} of panel function and corresponding legend grob
##' @param method panel function method (boxplot, lines, points,...); currently must be one of
##' "boxplot", "lines". Instead of "points", use "lines" with \code{type="b"}
##' @param type see lines() (for the panel function)
##' @param pch see legendGrob()
##' @param lwd line width for panel
##' @param cex (plot) character size (expansion) for panel
##' @param do.legend logical indicating if a legend should be added ....{FIXME}
##' @param leg.lwd line width for legend symbols
##' @param leg.cex size (expansion) for legend symbols and labels
##' @param leg.col legend colors
##' @param leg.expr legend labels as expressions
##' @param verbose option for marking NAs
##' @param ... additional parameters passed to the panel function
##' @author Marius Hofert
panelLegend <- function(method=c("boxplot", "lines"), type, pch,
lwd = 1, cex = 1, do.legend=TRUE,
leg.lwd = lwd, leg.cex = cex, leg.col, leg.expr,
panel.first = NULL, panel.last = NULL,
verbose=getOption("verbose"), ...)
{
## for marking NAs
markNA <- function(x.na, col) {
axis(1, at=x.na, labels=rep.int("N", length(x.na)),
mgp = c(1.5, 0.6, 0),
tick=FALSE, cex.axis=0.9, col.axis=adjustcolor(col, 0.8))
if(verbose)
message("NA's at x = ", paste(format(x.na, collapse=", ")))
}
## panel function
method <- match.arg(method)
panel <- switch(method,
"boxplot" = {
function(x, y, col, ...) {
stopifnot(is.matrix(y), (p <- length(x)) == ncol(y))
wex <- 0.5 * diff(range(x))/ p
if (!is.null(panel.first)) panel.first(x, y, col, ...)
boxplot.matrix(y, at = x, boxwex = wex, border = col,
col = NA, axes = FALSE, add = TRUE, names = FALSE,
## cex, lwd, pch: "globals" passed here:
cex = cex, lwd = lwd, pch = pch, ...)
my <- apply(y, 2, median, na.rm=TRUE)
lines(x, my, col=col, lwd=lwd) # lines
if(any(iy <- is.na(y))) { ## Mark NA's at the bottom
markNA(x[apply(iy, 2, any)], col)
}
if (!is.null(panel.last)) panel.last(x, y, col, ...)
}
},
"lines" = {
function(x, y, col, ...) {
## lines/points
if (!is.null(panel.first)) panel.first(x, y, col, ...)
lines(x, y, type=type, pch=pch, col=col, lwd=lwd, cex=cex, ...)
if(any(iy <- is.na(y))) markNA(x[iy], col) # Mark NA's at the bottom
if (!is.null(panel.last)) panel.last(x, y, col, ...)
}
},
stop(gettextf("method '%s' not yet implemented", method), domain=NA))
## legend function
lg <- if(do.legend) {
legendGrob(as.expression(leg.expr), nrow=1, pch=pch,
gp=gpar(col=leg.col, lwd=lwd, cex=cex))
## => if lwd is omitted, do.lines = FALSE => *nothing* plotted!
}
else nullGrob()
## return
list(panel=panel, legend=lg)
}
##' { end } panelLegend
##' Matrix plot with grid and gridBase, see help(mayplot) ../man/mayplot.Rd
##' { mayplot }
mayplot <- function(x, vList, row.vars = NULL, col.vars = NULL, xvar,
method = if(has.n.sim) "boxplot" else "lines",
panel.first = NULL, panel.last = NULL,
type = "l", pch = NULL, ylim = "global",
log = "", do.legend = TRUE,
spc = c(0.04/max(1,n.x-1), 0.04/max(1,n.y-1)),
axlabspc = c(0.12, 0.08), labspc = c(0.04, 0.04),
n.sim.spc = 0.06,
auxcol = c("gray40", "gray78", "gray90", "white"),
pcol = c("black", "blue", "red", "orange"), grid.lwd=1.6, ax.lwd=2,
tx.cex = 1.2, leg.cex = 1, xlab = NULL, ylab = NA,
do.n.sim = has.n.sim,
verbose = getOption("verbose"), show.layout = verbose, ...)
{
## basics ##################################################################
avar <- names( dn <- dimnames(x) ) # *a*ll variables
if(!all(avar %in% names(vList)))
stop("names(dimnames(.)) should all appear in names(vList)")
d <- dim(x)
if(!identical(avar, nd <- names(d))) {
if(!is.null(nd)) {
nonB <- nd != ""
if(any(nd[nonB] != avar[nonB]))
warning("names(dim(x)) do not match names(dimnames(x))")
}
names(d) <- avar
}
## deal with n.sim
has.n.sim <- "n.sim" %in% avar
if(has.n.sim) {
vLnsim <- vList[["n.sim"]]
if(vLnsim[["type"]] != "N")
message("\"n.sim\"'s \"type\" is not \"N\". Hopefully on purpose")
stopifnot((n.sim <- d[["n.sim"]]) == vLnsim[["value"]])
}
else if(method == "boxplot")
stop("method 'boxplot' not possible with no 'n.sim'")
## deal with boxplot case
if(method == "boxplot" && n.sim <= 4)
warning("box plots with ", n.sim, " values are rarely useful")
else if(method != "boxplot" && has.n.sim && n.sim > 1)
stop("has n.sim (= ", n.sim, ") > 1, but no boxplots.",
"\n *** error bars not yet implemented!")
## variables displayed in a single panel (different colors)
ovar <- c(xvar, col.vars, row.vars, if(has.n.sim) "n.sim") # *o*uter variables
if(!all(ovar %in% avar)) { ## error
if(!all(i <- xvar %in% avar))
stop(gettextf("'%s' entry *not* in names(dimnames(x)): \"%s\"\n",
"xvar", xvar[which(!i)[1]]), domain = NA)
if(!all(i <- col.vars %in% avar))
stop(gettextf("'%s' entry *not* in names(dimnames(x)): \"%s\"\n",
"col.vars", col.vars[which(!i)[1]]), domain = NA)
if(!all(i <- row.vars %in% avar))
stop(gettextf("'%s' entry *not* in names(dimnames(x)): \"%s\"\n",
"row.vars", row.vars[which(!i)[1]]), domain = NA)
}
v <- setdiff(avar, ovar) # variables displayed in a single panel
lv <- length(v) # number of different variables ('n', 'd',...) in a single panel
if(lv == 0) {
if(verbose) cat("no 'inner plot' variable 'v'\n")
v <- NULL
v.col <- pcol[1]
nv <- 0
} else if(lv == 1) {
nv <- length(dn[[v]]) # number of values the (single) panel plot variable 'v' takes
stopifnot(nv >= 1)
v.col <- colorRampPalette(pcol, space="Lab")(nv) # colors for v
} else stop("length(v)=", lv, " not yet implemented; too many variables (per plot panel)")
## TODO MM: great if this worked with length(v) == 2 {"n" & "d"}, and maybe > 2
## (e.g. *overplot*: one full plot for each "n" )
## => need to have accordingly many legend lines then
## permute so that we know the indices of v and outer variables (may be NULL)
avar.sort <- c(row.vars, col.vars, v, if(has.n.sim) "n.sim", xvar)
x <- aperm(x, perm = avar.sort) # permute x
## verbose
if(verbose) {
cat("xvar, col.vars, row.vars, v, n.sim : those *not* NULL are:\n")
print(c(xvar=xvar, col.vars=col.vars, row.vars=row.vars, v=v, n.sim=if(has.n.sim) n.sim))
cat("method = ", method, "; ", sep="")
stopifnot(identical(dim(x), unname(d[avar.sort])))
cat("dim(x {after aperm()}):\n"); print(d[avar.sort])
}
## z = value of xvar or seq_along() of it
xv <- vList[[xvar]]$value # *x* axis *v*alue
z <- if(is.character(xv) || is.recursive(xv)) seq_along(xv)
else {
z <- tryCatch(as.numeric(xv), error=function(e) e)
if(inherits(z, "error")) seq_along(xv) else z
}
zrange <- range(z) # for forcing the same x axis limits per row
if(method=="boxplot") zrange <- extendrange(zrange)
## ylim
ylim.msg <- "'ylim' must be \"global\", \"local\", or numeric of length two"
if(is.character(ylim)) {
ylim <- match.arg(ylim, c("global", "local"))
do.ylim <- ylim == "local"
if(!do.ylim) ylim <- range(x, na.rm=TRUE)
} else if(is.numeric(ylim)) {
do.ylim <- FALSE
if(!(length(ylim) == 2 && is.finite(ylim)))
stop(ylim.msg)
} else stop(ylim.msg)
do.legend <- do.legend && lv
## number of column/row variables
getdn <- function(nm) if(is.null(nm)) nm else dn[[nm]] # get dim names
nx <- length(getdn(col.vars)) # number of column variables
ny <- length(getdn(row.vars)) # number of row variables
## adjust for degenerate case
n.x <- max(1, nx) # number of columns to plot
n.y <- max(1, ny) # number of rows to plot
## panel (function) *and* legend (grob) ####################################
check.panel <- function(p)
is.function(p) && length(ff <- formals(p)) >= 3 &&
all(c("y", "col") %in% names(ff[-1])) # all but first must match
## construct default panel function with matching legend
if(is.null(pch)) pch <- if(type %in% c("p","o","b")) 1 # else NULL; pch from legendGrob()
## note: nv can be 0 in which case lexpr == list() [still works]
lexpr <- lapply(seq_len(nv), function(k)
substitute(expr == val,
list(expr=vList[[v]][["expr"]],
val=dn[[v]][k]))) # legend symbols and labels
pl <- panelLegend(method=method, type=type, pch=pch,
do.legend=do.legend,
leg.col=v.col, leg.expr=lexpr,
panel.first=panel.first, panel.last=panel.last,
verbose=verbose, leg.cex=leg.cex, ...)
## panel
panel <- pl$panel
stopifnot(check.panel(panel))
## legend
if(do.legend) {
legend.grob <- pl$legend
legspc <- 0.03 ### FIXME from grob! (and test with cex=0.5 or 2,etc)
}
stopifnot(length(spc) == 2, length(axlabspc) == 2,
length(labspc) == 2, length(auxcol) == 4)
## number of columns/rows in the layout
## for y axis label; (nx-1)* (plot+gaps); plot; row.vars labels :
## space for 1 (of n.x) plot in x direction:
w.all <- (axlabspc[1] + labspc[1] + n.sim.spc + (n.x-1)*spc[1])
if(w.all >= 1) stop("Choose smaller 'axlabspc[1]', 'labspc[1]', 'spc[1]', 'n.sim.spc'")
Pxsp <- (1 - w.all) / n.x
wid.gl <- c(axlabspc[1], # y axis label
rep(c(Pxsp, spc[1]), n.x-1), Pxsp, # panels (+ horizontal space in between)
labspc[1], # panel labels
if(has.n.sim) n.sim.spc) # if n.sim, 'second y axis' label
nx. <- length(wid.gl) # number of columns in the layout
## for col.vars labels; (ny-1)*(plot+gap); plot;
## space for 1 (of n.y) plot in y direction:
leg.spc <- if(do.legend) legspc else 0
h.all <- (labspc[2] + axlabspc[2] + leg.spc + (n.y-1)*spc[2])
if(h.all >= 1) stop("Choose smaller 'xlabspc[2]', 'labspc[2]', 'spc[2]', 'legspc'")
Pysp <- (1 - h.all) / n.y
hei.gl <- c(labspc[2], # panel labels
rep(c(Pysp, spc[2]), n.y-1), Pysp, # panels (+ vertical space in between)
axlabspc[2], # x axis label
if(do.legend) leg.spc) # legend
ny. <- length(hei.gl) # number of rows in the layout
## layout via grid #########################################################
## plot settings, restored on exit
opar <- par(no.readonly=TRUE); on.exit(par(opar))
plot.new() # start (empty) new page with 'graphics'; grid.newpage() fails here
## TODO MM: use smart units for widths/heights rather than just 'npc'
gl <- grid.layout(nrow=ny., ncol=nx., widths=wid.gl, heights=hei.gl,
## units in npc as for pdf()
## (no square plotting region otherwise)
default.units="npc")
if(show.layout) grid.show.layout(gl, vp=viewport(width=1.25, height=1.25))
pushViewport(viewport(layout=gl)) # use this layout in a viewport
## drawback of working with base graphics: layout has to be fully
## specified before plotting
## plot data ###############################################################
## walk over rows
for(i in 1:n.y)
{
i. <- 2*i # column index in layout (for jumping over gaps)
if(verbose) cat(sprintf("plot row %d (%d): [columns:] ", i, i.))
## pick out data to plot
xi <- # x for a fixed 'i'
if(ny) switch(length(d),
x[i ,drop=FALSE],
x[i , ,drop=FALSE],
x[i ,, ,drop=FALSE],
x[i ,,, ,drop=FALSE],
x[i ,,,, ,drop=FALSE],
stop(gettextf("'x' has wrong rank = length(dim(x)) = %d",
length(d))))
else x
if(do.ylim) ylim <- range(xi, na.rm=TRUE) # forcing same y axis limits per row
## walk over columns
for(j in 1:n.x)
{
j. <- 2*j # row index in layout (for jumping over gaps)
if(verbose) cat(sprintf("%d (%d) ", j, j.))
## push viewport
pushViewport(viewport(layout.pos.row=i., layout.pos.col=j.))
## plot panels #####################################################
## start a base graphics plot
par(plt=gridPLT(), new=TRUE) # Paul: always do this before each new base graphics plot
## set up coordinate system
plot.window(zrange, ylim, log=log)
## setup for background grid
## former base-graphics grid:
## grid.rect(gp=gpar(col=NA, fill=auxcol[3]))
## grid(col=auxcol[4], lty="solid", lwd=grid.lwd, equilogs=FALSE)
pxlog <- par("xlog")
pylog <- par("ylog")
v <- axTicks(1, axp=par("xaxp"), log=pxlog) # x values of vertical lines
h <- axTicks(2, axp=par("yaxp"), log=pylog) # y values of horizontal lines
if(pxlog) v <- log10(v)
if(pylog) h <- log10(h)
## => v, h have to be determined *here* [not in bgGrob()]
usr <- par("usr")
## background
grid.draw(bgGrob(v=v, h=h, vp=viewport(xscale=usr[1:2], yscale=usr[3:4]),
gp=gpar(col=auxcol[4], fill=auxcol[3])))
## panel
nxy <- nx && ny # TRUE <=> there is at least one row and one column
if(lv) {
for(k in 1:nv) {# walk over all variables plotted in a single panel
## y values
y. <- switch(length(d)-2, # length(ovar)-1 - has.n.sim,
if(nxy) xi[1,j,k] else if(ny) xi[1,,k] else xi[j,,k],
if(nxy) xi[1,j,k,] else if(ny) xi[1,,k,] else xi[j,,k,],
if(nxy) xi[1,j,k,,] else if(ny) xi[1,,k,,] else xi[j,,k,,],
stop("wrong length(ovar)"))
## panel
panel(z, y=y., col=v.col[k], ...)
}
} else { # no v (still n.sim or not)
## y values
y. <- switch(length(d)-1, # length(ovar) - has.n.sim,
if(nxy) xi[1,j] else if(ny) xi[1,] else xi[j,],
if(nxy) xi[1,j,] else if(ny) xi[1,,] else xi[j,,],
if(nxy) xi[1,j,,] else if(ny) xi[1,,,] else xi[j,,,],
stop("wrong length(ovar)"))
## panel
panel(z, y=y., col=v.col, ...)
}
## axes ############################################################
c.ax <- auxcol[1]
## x axis
if(i == n.y)
{
if(is.character(xv))
axis(1, at=z, labels=xv,
lwd=ax.lwd, col=NA, col.ticks=c.ax, col.axis=c.ax)
else
axis(1, lwd=ax.lwd, col=NA, col.ticks=c.ax, col.axis=c.ax)
if(is.null(xlab)) xlab <- vList[[xvar]]$expr
if(!identical(xlab, NA)) { # x axis label
## would need "with local viewport": but the push..()/up..()
## does not work WHY ???
## pushViewport(viewport(layout.pos.row=ny., layout.pos.col=j.))
## grid.text(xlab, x=1, y=0.9, # check.overlap=TRUE,
## gp = gpar(col = c.ax))
## popViewport()
## Using traditional graphics instead:
## mtext(xlab, side=1, at=zrange[2], col = c.ax, adj=c(0,0))
## ... TODO MM ... use grid! This *IS* ugly
## draw it between the last two tick marks :
axt <- axTicks(1)
at <- mean(axt[-1:0 + length(axt)])
mtext(xlab, side=1, at=at, col = c.ax, font = 2)#, adj=0.5
## draw axis arrow '-->' above the xlab:
## pu <- par("usr"); if(par("xlog")) pu[1:2] <- 10^pu[1:2]
## x0 <- pu[2] + (pu[2]-pu[1])
## x1 <- x0 + (x0 - pu[1])* spc[1]/Pxsp/2
## y0 <- pu[3]; if(par("ylog")) y0 <- 10^y0
## arrows(x0=x0, y0=y0, x1=x1, length=1/8, col = c.ax, xpd=NA)
}
}
## y axis
if(j == 1)
{
at <- axisTicks(par("usr")[3:4], log=par("ylog"))
if(packageVersion("sfsmisc") >= "1.0-21")
## allow for adjusting colors of small ticks
eaxis(2, at=at, lwd=ax.lwd, col=NA, col.ticks=c.ax, col.axis=c.ax, las = 1,
small.args=list(col=NA, col.ticks=c.ax, col.axis=c.ax))
else
eaxis(2, at=at, lwd=ax.lwd, col=NA, col.ticks=c.ax, col.axis=c.ax, las = 1)
}
popViewport()
## panel labels ####################################################
## column (col.vars) panel labels
if(i == 1 && !is.null(col.vars)) {
pushViewport(viewport(layout.pos.row=1, layout.pos.col=j.))
grid.rect(gp=gpar(col=NA, fill=auxcol[2]))
grid.text(tryExpr(dn[[col.vars]][j]), x=0.5, y=0.5, gp=gpar(cex=tx.cex))
popViewport()
}
## row (row.vars) panel labels
if(j == n.x && !is.null(row.vars)) {
pushViewport(viewport(layout.pos.row=i.,
layout.pos.col=if(has.n.sim) nx.-1 else nx.))
grid.rect(gp=gpar(col=NA, fill=auxcol[2]))
grid.text(tryExpr(dn[[row.vars]][i]), x=0.5, y=0.5, gp=gpar(cex=tx.cex),
rot=-90)
popViewport()
}
} # for(j ..)
if(verbose) cat("\n")
} # for(i ..)
## additionals #############################################################
## ylab
if(!identical(ylab, NA)) { # may be language where is.na(.) warns
max.row <- if(lv) ny.-2 else ny.-1
stopifnot(max.row >= 2) # defensive programming
## main
pushViewport(viewport(layout.pos.row=2:max.row, layout.pos.col=1))
grid.text(ylab, x=unit(0.6, "lines"), just=c("left", "centre"), rot=90)
popViewport()
}
## ylab2 (n.sim)
if(has.n.sim && do.n.sim) {
max.row <- if(lv) ny.-2 else ny.-1
stopifnot(max.row >= 2) # defensive programming
## main
pushViewport(viewport(layout.pos.row=2:max.row, layout.pos.col=nx.))
## note: vLnsim = vList[["n.sim"]] (which is defined if has.n.sim)
lab <- substitute(lab == val, list(lab=vLnsim[["expr"]], val=vLnsim[["value"]]))
grid.text(lab, y=unit(0, "npc"), # placing it at last/bottom panel(s)
just=c("left", "centre"), # given that point, use this (x, y) adjustment
rot=90, gp=gpar(cex=leg.cex))
popViewport()
}
## legend (for all variables appearing in a single panel)
if(do.legend)
{
## main
wran <- if(has.n.sim) 2:(nx.-2) else 2:(nx.-1) # width range
pushViewport(viewport(layout.pos.row=ny., layout.pos.col=wran))
grid.draw(legend.grob)
popViewport()
}
invisible(gl)
}
##' { end } mayplot
## ### pure grid (+lattice)
## if(FALSE) {##============ mayplotGrob() not yet ===================================
## ## From R-help (19 March 2010), by Baptiste Auguie
## latticeGrob <- function(x, ...) grob(.p. = x, cl="lattice", ...)
## ## ---
## ##' when grid.draw() does its battery of things, drawDetails() is one of them:
## drawDetails.lattice <- function(x, recording=FALSE) {
## lattice:::plot.trellis(x$.p., newpage=FALSE)
## ## ---
## }
## mayplotGrob <- function(x, vList, row.vars, col.vars, xvar, log = "",
## panelGrob = NULL,
## spc = c(0.04/max(1,n.x-1), 0.04/max(1,n.y-1)),
## auxcol = c("gray40", "gray78", "gray90", "white"),
## pcol = c("blue", "red", "orange"),
## xlab = NULL, ylab = NULL,
## ylim = "global", type = "l",
## doBoxp = has.n.sim,
## verbose = getOption("verbose"),
## vp.ex = 1, draw=TRUE, ...)
## {
## stopifnot(require("lattice"))
## ## auxiliary function for building names
## getName <- function(x) vapply(x, `[[`, "", "name")
## ## basics
## if(missing(row.vars)) row.vars <- NULL
## if(missing(col.vars)) col.vars <- NULL
## namD <- names( dn <- dimnames(x) )
## if(!all(namD %in% names(vList)))
## stop("names(dimnames(.)) should all appear in names(vList)")
## d <- dim(x)
## if(is.null(names(d))) names(d) <- namD else stopifnot(names(d) == namD)
## has.n.sim <- "n.sim" %in% namD
## if(has.n.sim) {
## vLnsim <- vList[["n.sim"]]
## stopifnot(vLnsim[["type"]] == "N",
## (n.sim <- d[["n.sim"]]) == vLnsim[["value"]])
## }
## else if(doBoxp) stop("no 'n.sim' -- doBoxp=TRUE is not possible")
## ## the variable displayed in one plot (with different colors):
## ovar <- c(xvar, col.vars, row.vars, if(has.n.sim) "n.sim")
## v <- setdiff(namD, ovar)
## ## TODO MM: great if this worked with length(v) == 2 {"n" & "d"}, and maybe > 2
## ## (e.g. *overplot*: one full plot for each "n" )
## if(doBoxp && n.sim <= 4)
## warning("box plots with ",n.sim," values are rarely useful")
## else if(!doBoxp && has.n.sim && n.sim > 1)
## stop("has n.sim (= ",n.sim,") > 1, but no boxplots.",
## "\n *** error bars not yet implemented!")
## if((lv <- length(v)) > 1)
## stop("length(v)=",lv," not yet implemented; too many variables (per plot panel)")
## if(lv == 0) {
## if(verbose) cat("no 'inner plot' variable 'v'\n")
## v <- NULL
## v.col <- pcol[1]
## } else { ## (lv >= 1)
## stopifnot(1 <= (nv <- length(dn[[v]])))
## ## if(nv > length(pcol))# not an error; can still work!
## ## warning("less colors in 'pcol' than values in ",v,
## ## " (", length(pcol)," < ", nv,")")
## v.col <- colorRampPalette(pcol, space="Lab")(nv) # colors for v
## }
## ## permute to know the component indices (v and others may be NULL !):
## p.x <- c(row.vars, col.vars, v, if(has.n.sim) "n.sim", xvar)
## x <- aperm(x, perm = p.x)
## if(verbose) {
## cat("xvar, col.vars, row.vars, v, n.sim : those *not* NULL are:\n")
## print(c(xvar=xvar, col.vars=col.vars,
## row.vars=row.vars, v=v, n.sim=if(has.n.sim) n.sim))
## if(is.null(panelGrob)) cat("doBoxp= ",doBoxp,"; ", sep="")
## stopifnot(identical(dim(x), unname(d[p.x])))
## cat("dim(x {after aperm()}):\n"); print(d[p.x])
## }
## if(is.null(xlab)) # default: the expression from varlist
## xlab <- vList[[xvar]]$expr
## xv <- vList[[xvar]]$value
## z <- if(is.character(xv) || is.recursive(xv)) seq_along(xv) else {
## z <- tryCatch(as.numeric(xv), error=function(e)e)
## if(inherits(z, "error")) seq_along(xv) else z
## }
## zrange <- range(z) # for forcing the same x axis limits per row
## if(doBoxp) zrange <- extendrange(zrange)
## if(is.null(panelGrob)) {
## markNA <- function(x.na, col) {
## ## FIXME this is still base-graphics
## xaxisGrob(1, at=x.na, labels=rep.int("N", length(x.na)),
## mgp = c(1.5, 0.6, 0),
## tick=FALSE, cex.axis=0.9, col.axis=adjustcolor(col, 0.8))
## if(verbose)
## message("NA's at x = ", paste(format(x.na, collapse=", ")))
## }
## panelGrob <-
## if(doBoxp)
## function(z, y, col, nv, ...) {
## stopifnot(is.matrix(y), (p <- length(z)) == ncol(y))
## stop("doBoxp not yet implemented here")
## wex <- 0.5 * diff(range(z))/ p
## boxplot.matrix(y, at = z, boxwex = wex, col=NA, border = col,
## axes=FALSE, add=TRUE, names=FALSE, ...)
## my <- apply(y, 2, median, na.rm=TRUE)
## lines(z, my, col=col) # <- not yet '...' (warnings)
## if(any(iy <- is.na(y))) { ## Mark NA's at the bottom
## markNA(z[apply(iy, 2, any)], col)
## }
## }
## else
## function(z, y, col, nv, ...) {
## ## plot corresponding points/lines
## lg <- linesGrob(z, y, type=type, col=col, ...)
## if(any(iy <- is.na(y))) { ## Mark NA's at the bottom
## markNA(z[iy], col)
## }
## }
## ## Workaround for now
## panelGrob <- function(z, y, col, nv, ...)
## rectGrob(gp = gpar(fill = "tomato")) # TODO for now!
## }
## else stopifnot(is.function(panelGrob),
## length(ff <- formals(panelGrob)) >= 4,
## ## the first argument can be named arbitrarily; the others must match:
## c("y", "col","nv") %in% names(ff[-1]))
## ylim.msg <- "'ylim' must be \"global\", \"local\", or numeric of length two"
## if(is.character(ylim)) {
## ylim <- match.arg(ylim, c("global", "local"))
## do.ylim <- ylim == "local"
## if(!do.ylim) ylim <- range(x, na.rm=TRUE)
## } else if(is.numeric(ylim)) {
## do.ylim <- FALSE
## if(!(length(ylim) == 2 && is.finite(ylim)))
## stop(ylim.msg)
## } else stop(ylim.msg)
## ## set up the grid layout
## getdn <- function(nm) if(is.null(nm)) nm else dn[[nm]]
## nx <- length(getdn(col.vars)) # number of plot columns
## ny <- length(getdn(row.vars)) # number of plot rows
## n.y <- max(1, ny)
## n.x <- max(1, nx)
## stopifnot(length(spc) == 2)
## ## build matrix structure
## ## basic matrix layout for panels
## res <- gtable(widths =unit(rep(1, n.x), "null"),
## heights=unit(rep(1, n.y), "null"))
## ## gmat <- gtable(## +1: add 1 column at the right border for 'row.var's:
## ## widths = unit(rep(1, n.x + 1), "null"),
## ## ## +1: add 1 row at the top border for 'col.var's:
## ## heights = unit(rep(1, n.y + 1), "null"))
## ###=========== WORK FROM HERE ========================================
## ## panels ##################################################################
## npanel <- function(ji)
## {
## i <- ji[2]
## xi <-
## if(ny) switch(length(d),
## x[i ,drop=FALSE],
## x[i , ,drop=FALSE],
## x[i ,, ,drop=FALSE],
## x[i ,,, ,drop=FALSE],
## x[i ,,,, ,drop=FALSE],
## stop(gettextf("'x' has wrong rank = length(dim(x)) = %d",
## length(d))))
## else x
## j <- ji[1]
## if(do.ylim)
## ylim <- range(xi, na.rm=TRUE) # for forcing the same y axis limits per row
## ## j. <- 2*j # row index in layout (for jumping over gaps)
## if(verbose) cat(sprintf("%d (%d) ", j))#, j.))
## ## prelim stuff
## ch <- paste0("panel (", io, ",", j, ")")
## nxy <- nx && ny
## if(lv) {
## ## FIXME: for(k in 1:nv)
## warning("nv=",nv, "; we are only drawing the first")
## k <- 1
## x. <- ## panel(z, y=
## switch(length(d)-2, #length(ovar)-1 -has.n.sim,
## if(nxy) xi[1,j,k] else if(ny) xi[1,,k] else xi[j,,k],
## if(nxy) xi[1,j,k,] else if(ny) xi[1,,k,] else xi[j,,k,],
## if(nxy) xi[1,j,k,,] else if(ny) xi[1,,k,,] else xi[j,,k,,],
## stop("wrong length(ovar)"))
## ## ,
## ## col = v.col[k], nv=nv, ...)
## } else # no 'v'; (still n.sim or not)
## x. <- ## panel(z, y=
## switch(length(d)-1, #length(ovar) -has.n.sim,
## if(nxy) xi[1,j] else if(ny) xi[1,] else xi[j,],
## if(nxy) xi[1,j,] else if(ny) xi[1,,] else xi[j,,],
## if(nxy) xi[1,j,,] else if(ny) xi[1,,,] else xi[j,,,],
## stop("wrong length(ovar)"))
## ## ,
## ## col = v.col, nv=0, ...)
## ## r.x <- length(dx <- dim(x))
## ## if(r.x == 5)
## ## x. <- x[i,j,,1,1] # points (for fixed 'tau', 'family'; additionally, we fix 'n' and 'd' here)
## ## else if(r.x == 4)
## ## x. <- x[i,j,1, ] # points ...
## ## else if(r.x == 3)
## ## x. <- x[i,j, ] # points ...
## ## else stop("silly panel not yet working for length(dim(x)) = ", r.x)
## ## plot x. (in alpha for each d)
## #z <- c(0.9, 0.95, 0.99, 0.999)
## xyscales <- list(y=list(log=TRUE, equispaced.log = FALSE),
## draw = FALSE)
## xy <- xyplot(x. ~ z, ## 2^(11:30)~11:30,
## scales= xyscales)
## gxy <- latticeGrob(xy, name="xy-grob")
## gTree(rectGrob(gp=gpar(fill=auxcol[3])), # background
## ## __TODO__: plot.window(zrange, ylim, log=log)
## ## gridGrob(.........)
## ## grid(col=auxcol[4], lty="solid", lwd=grid.lwd, equilogs=FALSE)
## if(verbose) textGrob(label=paste("Hi, I'm", ch)),
## if(FALSE)
## linesGrob(x = z,#c(0.9, 0.95, 0.99, 0.999),
## y = x.,
## default.units = "native",
## vp = dataViewport(z, x.)),
## gxy,
## name=ch)
## }
## ## construct panels
## ji.mat <- expand.grid(col=seq_len(n.x), row=seq_len(n.y),
## KEEP.OUT.ATTRS = FALSE)
## panels <- apply(ji.mat, 1, npanel) # compute panels
## ## add panels to plot (~> existing layout)
## ## (t, l): = (top,left)-positions (usual matrix index) in the layout;
## ## see res$layout and source of gtable_add_grob
## res <- gtable_add_grob(res, grobs=panels,
## t = ji.mat[,2], # 1, ..., 1, 2, ..., 2, n.y, ..., n.y
## l = ji.mat[,1], # 1, 2, ..., n.x, 1, 2, ..., n.x
## name=getName(panels))
## ## ## for y axis label; (nx-1)* (plot+gaps); plot; row.vars labels :
## ## ## space for 1 (of n.x) plot in x direction:
## ## Pxsp <- (1 - (axlabspc[1] + labspc[1]+ (n.x-1)*spc[1]))/ n.x
## ## wid.gl <- c(axlabspc[1], rep(c(Pxsp, spc[1]), n.x-1), Pxsp, labspc[1])
## ## ## for col.vars labels; (ny-1)*(plot+gap); plot; if(lv): {legend for v}
## ## ## space for 1 (of n.y) plot in y direction:
## ## leg.sp <- if(lv) legspc else 0
## ## Pysp <- (1 - (labspc[2]+ axlabspc[2]+ leg.sp + (n.y-1)*spc[2]))/ n.y
## ## hei.gl <- c(labspc[2], rep(c(Pysp, spc[2]), n.y-1), Pysp, axlabspc[2],
## ## if(lv) leg.sp)
## ## nx. <- length(wid.gl)
## ## ny. <- length(hei.gl)
## ## ## plot settings, restored on exit
## ## opar <- par(no.readonly=TRUE); on.exit(par(opar))
## ## plot.new() # start (empty) new page with 'graphics'
## ## ## TODO MM: use smart units for widths/heights rather than just 'npc'
## ## gl <- grid.layout(nrow=ny., ncol=nx., widths= wid.gl, heights = hei.gl,
## ## ## units in npc as for pdf(); no square plotting region otherwise:
## ## default.units="npc")
## ## if(show.layout) grid.show.layout(gl, vp=viewport(width=1.25, height=1.25))
## ## pushViewport(viewport(layout=gl)) # use this layout in a viewport
## ###---- currently "muted":
## if(FALSE)
## ## --- plot data ---
## for(i in 1:n.y) { # rows
## ## i. <- 2*i # column index in layout (for jumping over gaps)
## if(verbose) cat(sprintf("plot row %d (%d): [columns:] ", i))#, i.))
## xi <-
## if(ny) switch(length(d),
## x[i ,drop=FALSE],
## x[i , ,drop=FALSE],
## x[i ,, ,drop=FALSE],
## x[i ,,, ,drop=FALSE],
## x[i ,,,, ,drop=FALSE],
## stop(gettextf("'x' has wrong rank = length(dim(x)) = %d",
## length(d))))
## else x
## if(do.ylim)
## ylim <- range(xi, na.rm=TRUE) # for forcing the same y axis limits per row
## for(j in 1:n.x) { # columns
## ## j. <- 2*j # row index in layout (for jumping over gaps)
## if(verbose) cat(sprintf("%d (%d) ", j))#, j.))
## ## pushViewport(viewport(layout.pos.row=i., layout.pos.col=j.))
## ## plot
## ## grid.rect(gp=gpar(col=NA, fill=auxcol[3])) # background
## ## ## start a 'graphics' plot
## ## par(plt = gridPLT())
## ## par(new=TRUE) # always do this before each new 'graphics' plot
## ## ## set up coordinate system:
## ## plot.window(zrange, ylim, log=log)
## ## ## background grid:
## ## grid(col=auxcol[4], lty="solid", lwd=grid.lwd, equilogs=FALSE)
## nxy <- nx && ny
## if(lv) for(k in 1:nv)
## panel(z, y=
## switch(length(d)-2, #length(ovar)-1 -has.n.sim,
## if(nxy) xi[1,j,k] else if(ny) xi[1,,k] else xi[j,,k],
## if(nxy) xi[1,j,k,] else if(ny) xi[1,,k,] else xi[j,,k,],
## if(nxy) xi[1,j,k,,] else if(ny) xi[1,,k,,] else xi[j,,k,,],
## stop("wrong length(ovar)"))
## ,
## col = v.col[k], nv=nv, ...)
## else # no 'v'; (still n.sim or not)
## panel(z, y=
## switch(length(d)-1, #length(ovar) -has.n.sim,
## if(nxy) xi[1,j] else if(ny) xi[1,] else xi[j,],
## if(nxy) xi[1,j,] else if(ny) xi[1,,] else xi[j,,],
## if(nxy) xi[1,j,,] else if(ny) xi[1,,,] else xi[j,,,],
## stop("wrong length(ovar)"))
## ,
## col = v.col, nv=0, ...)
## ## axes
## c.ax <- auxcol[1]
## if(i == n.y) { # x axis
## if(is.character(xv))
## axis(1, at=z, labels=xv,
## lwd=ax.lwd, col=NA, col.ticks=c.ax, col.axis=c.ax)
## else
## axis(1, lwd=ax.lwd, col=NA, col.ticks=c.ax, col.axis=c.ax)
## if(!is.null(xlab) && !identical(xlab, NA)) { ## x axis label
## ## would need "with local viewport": but the push..()/up..()
## ## does not work WHY ???
## ## pushViewport(viewport(layout.pos.row=ny., layout.pos.col=j.))
## ## grid.text(xlab, x=1, y=0.9, # check.overlap=TRUE,
## ## gp = gpar(col = c.ax))
## ## popViewport()
## ## Using traditional graphics instead:
## ## mtext(xlab, side=1, at=zrange[2], col = c.ax, adj=c(0,0))
## ## ... TODO MM ... use grid! This *IS* ugly
## ## draw it between the last two tick marks :
## axt <- axTicks(1)
## at <- mean(axt[-1:0 + length(axt)])
## mtext(xlab, side=1, at=at, col = c.ax, font = 2)#, adj=0.5
## ## draw axis arrow '-->' above the xlab:
## ## pu <- par("usr"); if(par("xlog")) pu[1:2] <- 10^pu[1:2]
## ## x0 <- pu[2] + (pu[2]-pu[1])
## ## x1 <- x0 + (x0 - pu[1])* spc[1]/Pxsp/2
## ## y0 <- pu[3]; if(par("ylog")) y0 <- 10^y0
## ## arrows(x0=x0, y0=y0, x1=x1, length=1/8, col = c.ax, xpd=NA)
## }
## }
## if(j == 1) { # y axis
## at <- axisTicks(par("usr")[3:4], log=par("ylog"))
## if(packageVersion("sfsmisc") >= "1.0-21")
## ## allow for adjusting colors of small ticks
## eaxis(2, at=at, lwd=ax.lwd, col=NA, col.ticks=c.ax, col.axis=c.ax,
## las = ylas,
## small.args=list(col=NA, col.ticks=c.ax, col.axis=c.ax))
## else
## eaxis(2, at=at, lwd=ax.lwd, col=NA, col.ticks=c.ax, col.axis=c.ax,
## las = ylas)
## }
## popViewport()
## ## column labels (col.vars)
## if(i == 1 && !is.null(col.vars)) {
## pushViewport(viewport(layout.pos.row=1, layout.pos.col=j.))
## grid.rect(gp=gpar(col=NA, fill=auxcol[2]))
## grid.text(tryExpr(dn[[col.vars]][j]), x=0.5, y=0.5, gp=gpar(cex=tx.cex))
## popViewport()
## }
## ## row labels (row.vars)
## if(j == n.x && !is.null(row.vars)) {
## pushViewport(viewport(layout.pos.row=i., layout.pos.col=nx.))
## grid.rect(gp=gpar(col=NA, fill=auxcol[2]))
## grid.text(tryExpr(dn[[row.vars]][i]), x=0.5, y=0.5, gp=gpar(cex=tx.cex),
## rot=-90)
## popViewport()
## }
## }## for(j ..)
## if(verbose) cat("\n")
## }## for(i ..)
## ###---- currently "muted"
## ## panel labels ############################################################
## panelLabs <- function(i, rot=0, base.name=if(rot) "row" else "col")
## gTree(rectGrob(gp=gpar(fill="gray50")),
## textGrob(label=paste(base.name, "lab", i), rot=rot),
## name=paste("label", base.name, i))
## col.pLabs <- lapply(seq_len(n.x), panelLabs) # list of col panel label grobs
## row.pLabs <- lapply(seq_len(n.y), panelLabs, rot=-90) # list of row panel label grobs
## ## add col panel labels
## ## layout for col panel labels: pos = 0: on top
## res <- gtable_add_rows(res, heights=2*grobHeight(textGrob("X")), pos=0)
## res <- gtable_add_grob(res, grobs=col.pLabs, t=1, l=seq_len(n.x),
## name=getName(col.pLabs)) # fill in labels
## ## add row panel labels
## ## layout for row panel labels (pos = default): at "end", i.e., bottom:
## res <- gtable_add_cols(res, widths=2*grobHeight(textGrob("X")))
## res <- gtable_add_grob(res, grobs=row.pLabs, t=1+seq_len(n.y), l=n.x+1,
## name=getName(row.pLabs)) # fill in labels
## ## note: the t=1+... is due to the fact that we already added a row on top of the basic layout
## ## inter-row and -column space #############################################
## as.unit <- function(x) if(is.unit(x)) x else unit(x, "npc")
## spc <- as.unit(spc)
## for(i in rev(1L +seq_len(n.y-1L)))# "1+" already have top "col lab" labels
## res <- gtable_add_rows(res, heights= spc[2], pos=i) # row space
## for(j in rev(seq_len(n.x-1L)))
## res <- gtable_add_cols(res, widths = spc[1], pos=j) # col space
## ## labels ##################################################################
## res <- gtable_add_cols(res, widths =2*grobHeight(textGrob("X")))
## res <- gtable_add_rows(res, heights=2*grobHeight(textGrob("X")))
## ## TODO continue... (with filling in labels)
## if(draw) grid.draw(res)
## ## return
## invisible(res)
## }
## }##============ mayplotGrob() not yet ===================================
Try the simsalapar package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.