#########################################################################/**
# @RdocClass Device
#
# @title "The Device class"
#
# @synopsis
#
# \arguments{
# \item{filename}{A filename where to save the resulting plot. The
# filename suffix decides what graphical device driver will used.
# By default the screen will be used.}
# \item{restore.parameters}{
# Some graphical device drivers might change the global graphical
# parameters (see \code{par()}). \code{dev.open()} can restore them
# automatically if this argument is @TRUE. Default value is @FALSE
# since querying for graphical parameters opens up an annoying empty
# window if no window is opened.}
# }
#
# \description{
# @classhierarchy
#
# A class for creating graphical devices, plotting to them etc.
# }
#
# \section{Fields and Methods}{
# @allmethods
#
# }
#
# \value{
# The constructor returns a Device object.
# }
#
# \details{
# To set eps/ps or xfig options use .Postscript.Options
# (see \code{help(.Postscript.Options)}).
# To set bitmap arguments (bmp, jpg/jpeg, png and gif) use
# @see ".Bitmap.Options".
# To set default pictex arguments (tex/pictex) use
# @see ".PicTeX.Options".
#
# Supported devices are
# \code{screen}, \emph{eps, ps, bmp, jpg/jpeg, png, tex/pictex, xfig} and
# \emph{gif}. The gif device requires that ImageMagick
# (\url{http://www.imagemagick.org/}) is installed on the system path.
# To test if it is installed try \code{system("convert")}.
# }
#
# \examples{\dontrun{
# dev <- Device("myplot.eps")
# plot(1,1)
# dev$close()
#
# # and similar...
# plot(1,1)
# Device$print("myplot.eps")
# }}
#
# @author
#
# \seealso{Internally the \code{bmp},
# \code{jpeg}, @see "grDevices::pictex",
# @see "grDevices::png", @see "grDevices::postscript",
# @see "grDevices::xfig" in the \pkg{grDevices} package,
# and the @see "gif" in this package, and @see "eps".
# }
#
# \keyword{device}
#*/#########################################################################
setConstructorS3("Device", function(filename=NA, restore.parameters=FALSE) {
this <- extend(Object(), "Device",
filename = filename,
printPath = NULL
)
# constructor.Device(this, filename, restore.parameters);
this;
})
#########################################################################/**
# @RdocMethod getPrintPath
#
# @title "Gets the current path where figures are saved"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{Returns nothing.}
#
# @author
#
# \seealso{
# @seemethod "setPrintPath".
# }
#
# \keyword{dplot}
#*/#########################################################################
setMethodS3("getPrintPath", "Device", function(this, ...) {
this$printPath;
})
#########################################################################/**
# @RdocMethod setPrintPath
#
# @title "Sets the current path where figures are to be saved"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{path}{Filename path where figures are saved.}
# \item{...}{Not used.}
# }
#
# \value{Returns nothing.}
#
# @author
#
# \seealso{
# @seemethod "setPrintPath".
# }
#
# \keyword{dplot}
#*/#########################################################################
setMethodS3("setPrintPath", "Device", function(this, path, ...) {
this$printPath <- path;
})
setMethodS3("constructor", "Device", function(this, filename, restore.par=FALSE, ...) {
if (is.na(filename))
return(this);
filename <- this$filename;
if (is.null(filename) || filename == "screen") {
x11();
return(this);
} else if (inherits(filename, "File")) {
require(R.io) || throw("Package R.io was not found.");
filename <- getAbsolutePath(filename);
}
# For everything except "screen" call a device driver.
if (restore.par)
par.use <- par(no.readonly=TRUE);
require(R.basic) || throw("Package R.basic was not found.");
baseext <- baseAndExtension(filename) # From R.base
filename.base <- baseext[1];
filename.ext <- baseext[2];
if (filename.ext == "eps") {
postscript(filename, onefile=FALSE, horizontal=FALSE, paper="special");
} else if (filename.ext == "ps") {
postscript(filename, horizontal=FALSE);
} else if (filename.ext == "xfig") {
xfig(filename);
} else if (filename.ext == "png") {
opt <- getOptions(this, "bitmap");
png(filename, width=opt$width, height=opt$height, pointsize=opt$pointsize);
} else if (filename.ext == "gif") {
opt <- getOptions(this, "bitmap");
gif(filename, width=opt$width, height=opt$height, pointsize=opt$pointsize);
} else if (filename.ext == "bmp") {
opt <- getOptions(this, "bitmap");
bmp(filename, width=opt$width, height=opt$height, pointsize=opt$pointsize);
} else if (filename.ext == "jpeg" || filename.ext == "jpg") {
opt <- getOptions(this, "bitmap");
jpeg(filename, width=opt$width, height=opt$height, pointsize=opt$pointsize, quality=opt$quality);
} else if (filename.ext == "tex" || filename.ext == "pictex") {
opt <- getOptions(this, "pictex");
pictex(filename, width=opt$width, height=opt$height, debug=opt$debug, bg=opt$bg, fg=opt$fg);
}
if (restore.par) {
if (length(par.use) > 0) {
warn.old <- options("warn")[[1]];
options(warn=-1);
par(par.use);
options(warn=warn.old);
}
}
this;
}, private=TRUE, createGeneric=FALSE);
#########################################################################/**
# @RdocMethod getOptions
#
# @title "Get the current default options for a given device type"
#
# \description{
# @get "title".
#
# Retrieves options such as \code{width}, \code{height} etc for
# bitmap devices (bmp, jpg/jpeg, png and gif),
# pixtex devices (tex, pictex),
# and postscript devices (ps, eps), cf. @see "grDevices::ps.options".
# }
#
# @synopsis
#
# \arguments{
# \item{deviceType}{A @character string.}
# \item{names}{A @vector of names of options to be retrieved.
# If @NULL, all options are returned.}
# \item{...}{Not used.}
# }
#
# \value{Returns nothing.}
#
# @author
#
# \seealso{
# @seemethod "setOptions" and @seemethod "resetOptions".
# @see "grDevices::ps.options".
# }
#
# \keyword{dplot}
#*/#########################################################################
setMethodS3("getOptions", "Device", function(static, deviceType=c("bitmap", "pictex", "postscript"), names=NULL, ...) {
if (deviceType %in% c("postscript")) {
opt <- ps.options();
} else if (deviceType %in% c("bitmap")) {
if (!exists(".Bitmap.Options", mode="list"))
resetOptions(static, deviceType=deviceType);
opt <- .Bitmap.Options;
} else if (deviceType %in% c("pictex")) {
if (!exists(".PicTeX.Options", mode="list"))
resetOptions(static, deviceType=deviceType);
opt <- .PicTeX.Options;
} else {
throw("Unknown device type: ", deviceType);
}
if (!is.null(names))
opt <- opt[names];
opt;
}, static=TRUE)
#########################################################################/**
# @RdocMethod setOptions
#
# @title "Set the current default options for a given device type"
#
# \description{
# @get "title".
#
# Sets options such as \code{width}, \code{height} etc for a given
# device type.
# }
#
# @synopsis
#
# \arguments{
# \item{deviceType}{A @character string.}
# \item{...}{Name arguments of format \code{<name>=<value>}.}
# }
#
# \value{Returns nothing.}
#
# @author
#
# \seealso{
# @seemethod "getOptions" and @seemethod "resetOptions".
# }
#
# \keyword{dplot}
#*/#########################################################################
setMethodS3("setOptions", "Device", function(static, deviceType=c("bitmap", "pictex", "postscript"), ...) {
args <- list(...);
if (length(args) == 0)
return(getOptions(static, deviceType=deviceType));
if (deviceType %in% c("postscript")) {
old <- ps.options(...);
} else if (deviceType %in% c("bitmap")) {
optionName <- ".Bitmap.Options";
envir <- globalenv();
if (!exists(optionName, mode="list", envir=envir))
resetOptions(static, deviceType=deviceType);
new <- old <- get(optionName, envir=envir);
for (kk in seq(args)) {
name <- names(args)[kk];
new[name] <- args[kk];
}
assign(optionName, new, envir=envir);
} else if (deviceType %in% c("pictex")) {
optionName <- ".PicTeX.Options";
envir <- globalenv();
if (!exists(optionName, mode="list", envir=envir))
resetOptions(static, deviceType=deviceType);
new <- old <- get(optionName, envir=envir);
for (kk in seq(args)) {
name <- names(args)[kk];
new[name] <- args[kk];
}
assign(optionName, new, envir=envir);
} else {
throw("Unknown device type: ", deviceType);
}
invisible(old);
}, static=TRUE)
#########################################################################/**
# @RdocMethod resetOptions
#
# @title "Reset the current default options for a given device type"
#
# \description{
# @get "title".
#
# Resets the options for a given device type,
# e.g. bitmap, pictex and postscript.
# }
#
# @synopsis
#
# \arguments{
# \item{deviceType}{A @character string.}
# \item{...}{Not used.}
# }
#
# \value{Returns nothing.}
#
# @author
#
# \seealso{
# @seemethod "getOptions" and @seemethod "setOptions".
# }
#
# \keyword{dplot}
#*/#########################################################################
setMethodS3("resetOptions", "Device", function(static, deviceType=c("bitmap", "pictex", "postscript"), ...) {
if (deviceType %in% c("postscript")) {
ps.options(reset=TRUE);
Device$setOptions("postscript", width=5.0);
} else if (deviceType %in% c("bitmap")) {
optionName <- ".Bitmap.Options";
envir <- globalenv();
if (!exists(optionName, mode="list", envir=envir)) {
assign(optionName, list(), envir=envir);
}
Device$setOptions("bitmap", width=480,height=480,pointsize=12,quality=75);
} else if (deviceType %in% c("pictex")) {
optionName <- ".PicTeX.Options";
envir <- globalenv();
if (!exists(optionName, mode="list", envir=envir)) {
assign(optionName, list(), envir=envir);
}
Device$setOptions("pictex", width=5,height=4,debug=FALSE,bg="white",fg="black");
} else {
throw("Unknown device type: ", deviceType);
}
}, static=TRUE)
#########################################################################/**
# @RdocMethod open
#
# @title "Opens a device"
#
# \description{
# Static method to open a device, where the type is infered from the
# filename.
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Arguments passed to @seemethod "getParameters".}
# }
#
# \value{Returns nothing.}
#
# @author
#
# \seealso{
# @seemethod "getParameters".
# @seemethod "print".
#
# @seeclass
# }
#*/#########################################################################
setMethodS3("open", "Device", function(con, ...) {
# To please R CMD check...
this <- con;
params <- getParameters(this, ...);
Device$callFunction(function(dev, ...) dev(...), params=params);
}, static=TRUE);
#########################################################################/**
# @RdocMethod print
#
# @title "Prints device to file"
#
# \description{
# Static method for direct printing of the current plot to a device,
# where the device type is infered from the filename.
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Arguments passed to @seemethod "getParameters".}
# }
#
# \value{Returns nothing.}
#
# \examples{
# plot(1,1)
# \dontrun{Device$print("myplot.jpg")}
# }
#
# @author
#
# \seealso{
# @seemethod "getParameters".
# Internally @see "grDevices::dev.print" is used.
# Default values of dimensions etc. are specified by
# @see ".Bitmap.Options", @see ".PicTeX.Options" and
# \code{.PostScript.Options} (see @see "grDevices::postscript").
# @seemethod "open".
#
# @seeclass
# }
#*/#########################################################################
setMethodS3("print", "Device", function(x, ...) {
# To please R CMD check...
this <- x;
params <- getParameters(this, ...);
callFunction(this, fcn=dev.print, params=params);
}, static=TRUE);
setMethodS3("callFunction", "Device", function(static, fcn, params, ...) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Validating arguments
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if (!is.function(fcn))
throw("Argument 'fcn' is not a function: ", mode(fcn));
if (!is.list(params))
throw("Argument 'params' is not a list: ", mode(list));
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Calling device function
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# To please R CMD check
imgType <- pathname <- width <- height <- pointsize <- NULL;
rm(imgType, pathname, width, height, pointsize);
attachLocally(params);
if (imgType == "eps") {
fcn(postscript, pathname, onefile=FALSE, horizontal=FALSE,
paper="special", width=width, height=height);
} else if (imgType == "ps") {
fcn(postscript, pathname, horizontal=FALSE, width=width, height=height)
} else if (imgType == "xfig") {
xfig <- get("xfig", mode="function")
fcn(xfig, pathname)
} else if (imgType == "png") {
png <- get("png", mode="function")
fcn(png, pathname, width=width, height=height,
pointsize=pointsize)
} else if (imgType == "gif") {
gif <- get("gif", mode="function")
fcn(gif, pathname, width=width, height=height, pointsize=pointsize)
} else if (imgType == "bmp") {
bmp <- get("bmp", mode="function")
fcn(bmp, pathname, width=width, height=height,
pointsize=pointsize)
} else if (imgType == "jpeg" || imgType == "jpg") {
if (is.null(quality)) {
opt <- getOptions(static, "bitmap");
quality <- opt$quality;
}
jpeg <- get("jpeg", mode="function")
fcn(jpeg, pathname, width=width, height=height,
pointsize=pointsize, quality=quality)
} else if (imgType == "tex" || imgType == "pictex") {
opt <- getOptions(static, "pictex");
if (is.null(debug))
debug <- opt$debug
if (is.null(fg))
fg <- opt$fg
if (is.null(bg))
bg <- opt$bg
pictex <- get("pictex", mode="function")
fcn(pictex, pathname, width=width, height=height,
debug=debug, bg=bg, fg=fg)
}
}, protected=TRUE, static=TRUE);
#########################################################################/**
# @RdocMethod getParameters
#
# @title "Gets parameters specific to a certain type of device"
#
# \description{
# @get "title".
# This method is used by @seemethod "print" and @seemethod "open".
# }
#
# @synopsis
#
# \arguments{
# \item{filename}{A filename where to save the resulting plot. The
# filename suffix decides what graphical device driver will used.}
# \item{path}{The output path where the figure is saved.}
# \item{width, height}{The width and height of the image. If both are
# @NULL the graphical device driver's default settings are used.
# If one of them are missing, the other one are set to the default
# value according to the default settings and the missing argument
# is assumed to be of size \code{"100\%"}. If any of the two are given
# as a percentage string, e.g. \code{"75\%"}, its value is calculated
# to of that percentage of the other value, which must be absolute.}
# \item{aspectRatio}{If @TRUE, the height will be defined by the
# aspect ratio of the current device. If @numeric, height will be
# the width times the aspect ratio. Otherwise aspectRatio is ignored.}
# \item{pointsize}{The font pointsize to be used. If @NULL the
# graphical device driver's default settings are used.}
# \item{quality}{The quality in [0,100]\% if applicable. This argument is
# currently only used by the jpeg device driver. If @NULL the
# graphical device driver's default settings are used.}
# \item{bg, fg}{Background and foreground colors used by the PicTeX
# driver. If @NULL the graphical device driver's default settings
# are used.}
# \item{debug}{Used by the PicTeX driver. If @NULL the graphical
# device driver's default settings are used.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns a named @list structure with elements
# \code{pathname}, \code{imgName}, \code{imgType},
# \code{height}, \code{width}, \code{aspectRatio},
# \code{quality}, \code{pointsize},
# \code{bg}, \code{fg}, and \code{debug}.
#
# Value \code{pathname} is the pathname to the image file validate to
# writable.
# Value \code{imgName} is the basename of the pathname without the
# filename extension, which is returned (in lower case) by \code{imgType}.
# }
#
# @author
#
# \seealso{
# @seemethod "print" and @seemethod "open".
# @seeclass
# }
#*/#########################################################################
setMethodS3("getParameters", "Device", function(this, filename=this$filename, path=getPrintPath(this), width=NULL, height=NULL, aspectRatio=NULL, pointsize=NULL, quality=NULL, bg=NULL, fg=NULL, debug=NULL, ...) {
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Validating arguments
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Argument 'filename' and 'path'.
pathname <- Arguments$getWritablePathname(filename, path=path);
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Extracting image name and image extension
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
pattern <- "(.*)[.]([^.]*)$";
imgName <- gsub(pattern, "\\1", basename(pathname));
imgType <- gsub(pattern, "\\2", basename(pathname));
imgType <- tolower(imgType);
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Setting the default width and the height depending on the device.
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if (is.element(imgType, c("png", "gif", "bmp", "jpg", "jpeg"))) {
opt <- getOptions(this, "bitmap");
defHeight <- opt$height
defWidth <- opt$width;
defPointsize <- opt$pointsize;
} else if (is.element(imgType, c("ps", "eps"))) {
opt <- getOptions(this, "postscript");
defWidth <- opt$width;
defHeight <- opt$height;
defPointsize <- opt$pointsize;
} else if (is.element(imgType, c("tex", "pictex"))) {
opt <- getOptions(this, "pictex");
defWidth <- opt$width;
defHeight <- opt$height;
defPointsize <- opt$pointsize;
}
# If the default width is zero, set it to 100%! of the device
if (defWidth == 0)
defWidth <- "100%!"
else if (defHeight == 0)
defHeight <- "100%!";
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Calculate the width
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if (is.null(width))
width <- defWidth;
if (is.character(width)) {
if (regexpr("^[0-9][0-9]*%$", width) != -1) {
width <- as.numeric(gsub("%", "", width)) / 100 * defWidth;
} else if (regexpr("^[0-9][0-9]*%!$", width) != -1) {
if (is.null(height))
height <- defHeight;
if (!is.numeric(height))
throw("Can not calculate relative size of the width since numeric value of argument 'height' is missing: ", width);
if (isZero(height))
throw("Can not calculate relative size of the width since 'height'is zero (see ?setOptions.Device): ", width);
width <- as.numeric(gsub("%!", "", width)) / 100 * height;
}
} else if (!is.numeric(width)) {
width <- defWidth;
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Calculate the height
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if (is.null(height)) {
# Assure that the aspect ratio is the same as on the device
if (identical(aspectRatio, TRUE)) {
height <- width * getAspectRatio(this, what="plot");
} else if (is.numeric(aspectRatio)) {
height <- width * aspectRatio;
} else {
height <- defHeight;
}
} # if (is.null(height))
if (is.character(height)) {
if (regexpr("^plot:", height) != -1) {
height <- as.numeric(gsub("^plot:", "", height));
devAspectRatio <- getAspectRatio(this, what="device");
plotAspectRatio <- getAspectRatio(this, what="plot");
effAspectRatio <- plotAspectRatio/devAspectRatio;
print(c(height=height, effAspectRatio=effAspectRatio));
height <- height * width / effAspectRatio;
# height <- 0.84 * height;
print(c(width=width, height=height));
} else if (regexpr("^[0-9][0-9]*%$", height) != -1) {
height <- as.numeric(gsub("%", "", height)) / 100 * defWidth;
} else if (regexpr("^[0-9][0-9]*%!$", height) != -1) {
if (is.null(width))
width <- defWidth;
if (!is.numeric(width))
throw("Can not calculate relative size of the height since numeric value of argument 'width' is missing: ", height);
height <- as.numeric(gsub("%!", "", height)) / 100 * width;
}
} else if (!is.numeric(height)) {
height <- defHeight;
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
# Calculate the pointsize
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
if (is.character(pointsize)) {
pointsize <- as.numeric(gsub("%", "", pointsize)) / 100 * defPointsize;
} else if (!is.numeric(pointsize)) {
pointsize <- defPointsize;
}
list(
pathname = pathname,
imgName = imgName,
imgType = imgType,
height = height,
width = width,
aspectRatio = aspectRatio,
quality = quality,
pointsize = pointsize,
bg = bg,
fg = fg,
debug = debug
);
}, static=TRUE);
#########################################################################/**
# @RdocMethod close
#
# @title "Closes the device"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{Returns nothing.}
#
# \examples{\dontrun{
# dev <- Device("myplot.eps")
# plot(1,1)
# dev$close()
# }}
#
# @author
#
# \seealso{
# \code{\link[grDevices:dev]{dev.off}}.
#
# @seeclass
# }
#*/#########################################################################
setMethodS3("close", "Device", function(con, ...) {
# To please R CMD check...
this <- con;
if (!is.na(this$filename))
dev.off();
this$filename <- NA;
})
#########################################################################/**
# @RdocMethod closeAll
#
# @title "Closes all open devices"
#
# \description{
# Static method that closes all open devices.
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{Returns the number of closed devices.}
#
# \examples{\dontrun{
# Device("myplot.eps")
# plot(1,1)
# Device("myplot.jpg")
# plot(1,1)
# Device$closeAll()
# }}
#
# @author
#
# \seealso{
# \code{\link[grDevices:dev]{graphics.off}}.
#
# @seeclass
# }
#*/#########################################################################
setMethodS3("closeAll", "Device", function(this, ...) {
graphics.off();
}, static=TRUE);
#########################################################################/**
# @RdocMethod set
#
# @title "Sets the current device index"
#
# \description{
# Static method that sets the current device index. If there exists no
# device with that index a device with that index will be created. This
# might result in several intermediate device will have to be opened, but
# they will be closed before returned.
# Similar to Matlab's \code{figure} function.
# }
#
# @synopsis
#
# \arguments{
# \item{index}{The index to which the current device will be set to.}
# \item{device}{Specifies the device driver devices that might be opened.}
# \item{...}{Not used.}
# }
#
# \value{Returns the number of opened devices.}
#
# @author
#
# \seealso{
# \code{\link[grDevices:dev]{dev.set}}.
#
# @seeclass
# }
#*/#########################################################################
setMethodS3("set", "Device", function(this, index, device=x11, width=NULL, height=NULL, ...) {
defOptions <- check.options(new=list(), envir=grDevices:::.WindowsEnv,
name.opt=".Windows.Options");
defWidth <- defOptions$width;
defHeight <- defOptions$height;
if (defWidth == 0)
defWidth <- "100%!"
else if (defHeight == 0)
defHeight <- "100%!";
if (is.null(width))
width <- defWidth;
if (is.character(width)) {
if (regexpr("^[0-9][0-9]*%$", width) != -1) {
width <- as.numeric(gsub("%", "", width)) / 100 * defWidth;
} else if (regexpr("^[0-9][0-9]*%!$", width) != -1) {
if (is.null(height))
height <- defHeight;
if (!is.numeric(height))
throw("Can not calculate relative size of the width since numeric value of argument 'height' is missing: ", width);
width <- as.numeric(gsub("%!", "", width)) / 100 * height;
}
} else if (!is.numeric(width)) {
width <- defWidth;
}
if (is.null(height))
height <- defHeight;
if (is.character(height)) {
if (regexpr("^[0-9][0-9]*%$", height) != -1) {
height <- as.numeric(gsub("%", "", height)) / 100 * defWidth;
} else if (regexpr("^[0-9][0-9]*%!$", height) != -1) {
if (is.null(width))
width <- defWidth;
if (!is.numeric(width))
throw("Can not calculate relative size of the height since numeric value of argument 'width' is missing: ", height);
height <- as.numeric(gsub("%!", "", height)) / 100 * width;
}
} else if (!is.numeric(height)) {
height <- defHeight;
}
if (index < 2)
stop("Argument 'index' must be two or larger.");
# If the device is already opened just move to it.
if (Device$isOpen(index)) {
dev.set(index);
return(invisible(0));
}
toBeOpened <- setdiff(2:index, dev.list());
len <- length(toBeOpened);
if (len > 0) {
for (idx in toBeOpened) device(width=width, height=height);
toBeClosed <- setdiff(toBeOpened, index);
for (idx in toBeClosed) {
dev.set(idx); dev.off();
}
}
dev.set(index);
return(invisible(len));
}, static=TRUE);
#########################################################################/**
# @RdocMethod isOpen
#
# @title "Checks if a device is open or not"
#
# \description{
# @get "title".
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Use 'index' as the index of the device.}
# }
#
# \value{
# Returns @TRUE if the device is open, otherwise @FALSE.
# }
#
# @author
#
# \seealso{
# \code{\link[grDevices:dev]{dev.list}}.
#
# @seeclass
# }
#*/#########################################################################
setMethodS3("isOpen", "Device", function(con, ...) {
# To please R CMD check
this <- con;
args <- list(...);
index <- args$index;
if (is.null(index)) index <- args[[1]];
stopifnot(!is.null(index));
if (index < 2)
stop("Argument 'index' must be two or larger.");
is.element(index, dev.list())
}, static=TRUE);
#########################################################################/**
# @RdocMethod getNext
#
# @title "Opens the next device"
#
# \description{
# @get "title". If no such device exists, the a new device is opened.
# }
#
# @synopsis
#
# \arguments{
# \item{index}{The index of the \emph{current device}.}
# \item{device}{Specifies the device driver devices that might be opened.}
# \item{...}{Not used.}
# }
#
# \value{Returns the id number of the opened device.}
#
# @author
#
# \seealso{
# \code{\link[grDevices:dev]{dev.set}}.
#
# @seeclass
# }
#*/#########################################################################
setMethodS3("getNext", "Device", function(this, index=dev.cur(), device=x11, ...) {
Device$set(index+1);
}, static=TRUE);
#########################################################################/**
# @RdocMethod new
#
# @title "Creates a new device"
#
# \description{
# Static method that creates a new device.
# }
#
# @synopsis
#
# \arguments{
# \item{device}{Specifies the device driver devices that might be opened.}
# \item{...}{Not used.}
# }
#
# \value{Returns the id number of the opened device.}
#
# @author
#
# \seealso{
# \code{\link[grDevices:dev]{dev.set}}.
#
# @seeclass
# }
#*/#########################################################################
setMethodS3("new", "Device", function(this, device=x11, ...) {
device();
dev.cur();
}, static=TRUE);
setMethodS3("finalize", "Device", function(this, ...) {
close(this);
})
#########################################################################/**
# @RdocMethod bringToTop
#
# @title "Bring a device to top"
#
# \description{
# @get "title". By default it is the current active device that will
# be brought to top.
# }
#
# @synopsis
#
# \arguments{
# \item{which}{Index (an @integer) of device.}
# \item{...}{Not used.}
# }
#
# \value{
# Returns nothing.
# }
#
# @author
#
# \seealso{
# @seeclass
# }
#*/#########################################################################
setMethodS3("bringToTop", "Device", function(static, which=dev.cur(), ...) {
devs <- dev.list();
if (!is.element(which, devs))
throw("Can not bring device to top. No such (windows) device: ", which);
wins <- devs[names(devs) == "windows"];
if (!is.element(which, wins))
throw("Can not bring device to top. The device is not a windows device: ", which, " (", names(devs)[which-1], ")");
bringToTop(which=which);
}, static=TRUE)
setMethodS3("setPlotParameters", "Device", function(this, ..., new=FALSE, dev=NULL) {
if (is.null(dev)) {
dev <- dev.cur();
if (new || length(dev.list()) == 0) dev <- dev+1;
} else if (new)
dev <- dev+1;
if (dev == 1)
throw("There is no current plot available.");
envir <- globalenv();
if (exists(".plotParameters", envir=envir, inherits=FALSE)) {
.plotParameters <- get(".plotParameters", envir=envir);
} else {
.plotParameters <- list();
}
.plotParameters[[dev]] <- list(...);
assign(".plotParameters", .plotParameters, envir=envir);
}, static=TRUE);
setMethodS3("getPlotParameters", "Device", function(this, dev=NULL, ...) {
if (is.null(dev))
dev <- dev.cur();
envir <- globalenv();
if (exists(".plotParameters", envir=envir, inherits=FALSE)) {
.plotParameters <- get(".plotParameters", envir=envir);
if (length(.plotParameters) >= dev)
return(.plotParameters[[dev]]);
}
list();
}, static=TRUE);
##############################################################################
# @RdocMethod putTimestamp
#
# \description{
# The 'put.timestamp' option is used to set timestamps on plots. By
# default the date is printed automatically (if the plot function supports
# this option) on the right hand side of the plot (side=4) and right
# adjusted (adj=1). The default font size is 80% (cex=0.6) and the default
# font color is gray (col="darkgray"). The timestamp is plotted on either
# the inner (outer=FALSE) or the outer margin (outer=TRUE). Counting from
# inside towards the edge of the device, the timestamp can be printed on
# any line, default is line=1.
# }
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{
# Returns @TRUE if the timestamp was added, otherwise @FALSE.
# }
#
# \seealso{
# The \code{putTimestamp.Device} method is making use of
# the funcion @see "graphics::mtext" for writing text in margins.
#
# @seeclass
# }
##############################################################################
if (is.null(getOption("put.timestamp")))
options(put.timestamp=list(auto=TRUE, side=4, adj=1, cex=0.7, col="darkgray", line=0, outer=TRUE));
setMethodS3("putTimestamp", "Device", function(this, timestamp=date(), auto=NULL, side=NULL, adj=NULL, cex=NULL, col=NULL, line=NULL, outer=NULL, device=NULL, ...) {
if (is.null(timestamp) || is.na(timestamp)) return(invisible(FALSE));
o <- getOption("put.timestamp");
if (is.null(auto)) auto <- o$auto;
if (is.null(auto) || !is.logical(auto) || !auto)
return(invisible(FALSE));
if (is.null(adj)) adj <- o$adj;
if (is.null(adj)) adj <- 1;
if (is.null(cex)) cex <- o$cex;
if (is.null(cex)) cex <- 0.7;
if (is.null(col)) col <- o$col;
if (is.null(col)) col <- "darkgray";
if (is.null(side)) side <- o$side;
if (is.null(side)) side <- 4;
if (is.null(line)) line <- o$line;
if (is.null(line)) line <- 0;# + 1*(side == 1 || side == 4);
if (is.null(outer)) outer <- o$outer;
if (is.null(outer)) outer <- TRUE;
if (outer) line <- par("oma")[side] - line - 1;
if (!is.null(device)) {
if (!is.element(device, dev.list()))
stop(paste("Can not set timestamp on device", device,
"since it does not exists."));
dev.cur <- dev.cur();
dev.set(device);
}
mtext(timestamp, side=side, adj=adj, cex=cex, col=col, line=line, outer=outer);
if (!is.null(device)) dev.set(dev.cur);
return(invisible(TRUE));
}, static=TRUE)
if (is.null(getOption("put.dataset")))
options(put.dataset=list(auto=TRUE, side=4, adj=0, cex=0.7, col="darkgray", line=0, outer=TRUE));
setMethodS3("putDataset", "Device", function(this, dataset=getOption("dataset"), auto=NULL, side=NULL, adj=NULL, cex=NULL, col=NULL, line=NULL, outer=NULL, device=NULL, ...) {
if (is.null(dataset) || is.na(dataset)) return(invisible(FALSE));
o <- getOption("put.dataset");
if (is.null(auto)) auto <- o$auto;
if (is.null(auto) || !is.logical(auto) || !auto)
return(invisible(FALSE));
if (is.null(adj)) adj <- o$adj;
if (is.null(adj)) adj <- 0;
if (is.null(cex)) cex <- o$cex;
if (is.null(cex)) cex <- 0.7;
if (is.null(col)) col <- o$col;
if (is.null(col)) col <- "darkgray";
if (is.null(side)) side <- o$side;
if (is.null(side)) side <- 4;
if (is.null(line)) line <- o$line;
if (is.null(line)) line <- 0; # + 1*(side == 1 || side == 4);
if (is.null(outer)) outer <- o$outer;
if (is.null(outer)) outer <- TRUE;
if (outer) line <- par("oma")[side] - line - 1;
if (!is.null(device)) {
if (!is.element(device, dev.list()))
stop(paste("Can not set dataset on device", device,
"since it does not exists."));
dev.cur <- dev.cur();
dev.set(device);
}
mtext(dataset, side=side, adj=adj, cex=cex, col=col, line=line, outer=outer);
if (!is.null(device)) dev.set(dev.cur);
return(invisible(TRUE));
}, static=TRUE)
if (is.null(getOption("put.author")))
options(put.author=list(auto=TRUE, side=4, adj=0, cex=0.7, col="darkgray", line=0, outer=TRUE));
setMethodS3("putAuthor", "Device", function(this, author=getOption("author"), auto=NULL, side=NULL, adj=NULL, cex=NULL, col=NULL, line=NULL, outer=NULL, device=NULL, ...) {
if (is.null(author) || is.na(author)) return(invisible(FALSE));
o <- getOption("put.author");
if (is.null(auto)) auto <- o$auto;
if (is.null(auto) || !is.logical(auto) || !auto)
return(invisible(FALSE));
if (is.null(adj)) adj <- o$adj;
if (is.null(adj)) adj <- 0;
if (is.null(cex)) cex <- o$cex;
if (is.null(cex)) cex <- 0.7;
if (is.null(col)) col <- o$col;
if (is.null(col)) col <- "darkgray";
if (is.null(side)) side <- o$side;
if (is.null(side)) side <- 4;
if (is.null(line)) line <- o$line;
if (is.null(line)) line <- 0; # + 1*(side == 1 || side == 4);
if (is.null(outer)) outer <- o$outer;
if (is.null(outer)) outer <- FALSE;
if (outer) line <- par("oma")[side] - line - 1;
if (!is.null(device)) {
if (!is.element(device, dev.list()))
stop(paste("Can not set author on device", device,
"since it does not exists."));
dev.cur <- dev.cur();
dev.set(device);
}
mtext(author, side=side, adj=adj, cex=cex, col=col, line=line, outer=outer);
if (!is.null(device)) dev.set(dev.cur);
return(invisible(TRUE));
}, static=TRUE)
#########################################################################/**
# @RdocMethod subplots
#
# @title "Creates a grid of subplots"
#
# \description{
# @get "title" in the current figure. If arguments
# \code{nrow} and \code{ncol} are given a \code{nrow}-by-\code{ncol}
# grid of subplots are created. If only argument \code{n} is given
# then a r-by-s grid is created where |r-s| <= 1, i.e. a square or almost
# a square of subplots is created. If \code{n} and \code{nrow} is
# given then a grid with \code{nrow} rows and at least \code{n} subplots
# are created. Similar if \code{n} and \code{ncol} is given.
# The argument \code{byrow} specifies if the order of the subplots
# should be rowwise (\code{byrow=TRUE}) or columnwise.
# }
#
# @synopsis
#
# \arguments{
# \item{n}{If given, the minimum number of subplots.}
# \item{nrow}{If given, the number of rows the grid of subplots should
# contain.}
# \item{ncol}{If given, the number of columns the grid of subplots should
# contain.}
# \item{...}{Not used.}
# }
#
# \value{Returns the @matrix containing the order of plots.}
#
# @author
#
# \examples{
# Device$subplots(nrow=2, ncol=3) # 2-by-3 grid of subplots
# Device$subplots(n=6, nrow=2) # 2-by-3 grid of subplots
# Device$subplots(n=5, ncol=2) # 3-by-2 grid of subplots
# Device$subplots(1) # (Reset) to a 1-by-1 grid of subplots
# Device$subplots(2) # 1-by-2 grid of subplots
# Device$subplots(3) # 2-by-2 grid of subplots
# l <- Device$subplots(8) # 3-by-3 grid of subplots
# layout.show(length(l))
# }
#
# \seealso{
# @see "graphics::layout" and \code{layout.show}().
# }
#*/#########################################################################
setMethodS3("subplots", "Device", function(this, n=1, nrow=NULL, ncol=NULL,
byrow=TRUE, ...) {
# If a vector was passed, then use the length of the vector for 'n'
if (!missing(n) && length(n) > 1)
n <- length(n);
if (!is.null(nrow) && !is.null(ncol) && !missing(n)) {
if (n != nrow*ncol)
stop("Arguments 'nrow' and 'ncol' is incompatible with argument 'n'. Do you really want to specify all three?!");
}
if (missing(n)) {
layout <- matrix(seq(nrow*ncol), nrow=nrow, ncol=ncol, byrow=byrow);
} else {
if (n == 1) {
nrow <- ncol <- 1
} else if (!is.null(nrow)) {
ncol <- ceiling(n / nrow);
} else if (!is.null(ncol)) {
nrow <- ceiling(n / ncol);
} else {
side <- sqrt(n);
nrow <- floor(side);
ncol <- ncol-1;
ncol <- ceiling(n / nrow);
if (ncol - nrow > 1) {
nrow <- nrow+1;
ncol <- ceiling(n / nrow);
}
}
layout <- matrix(seq(nrow*ncol), nrow=nrow, ncol=ncol, byrow=byrow);
}
layout(layout, ...);
invisible(layout);
}, static=TRUE);
setMethodS3("subplots", "ANY", function(...) {
Device$subplots(...);
}, static=TRUE);
#########################################################################/**
# @RdocMethod setStyle
#
# @title "Sets plot style for the current device"
#
# \description{
# @get "title" from a set of predefined plot styles.
# Available styles are \code{default} and \code{PowerPoint}.
# The style \code{default} is the default parameter settings used by [R]
# and the style \code{PowerPoint} is a style for generating plots to be
# used in the presentations, which requires fatter lines, larges fonts etc.
# }
#
# @synopsis
#
# \arguments{
# \item{style}{The name of the predefined plot style to be applied.}
# \item{...}{Not used.}
# }
#
# \value{Returns nothing.}
#
# @author
#
# \examples{
# Device$setStyle("PowerPoint")
# plot(sin(0:1000))
# Device$setStyle() # Reset to default [R] settings.
# }
#
# \seealso{
# @see "graphics::par"
#
# @seeclass
# }
#*/#########################################################################
setMethodS3("setStyle", "Device", function(this,
style=c("default", "PowerPoint"), ...) {
# Annoyingly, when calling par() it will actually open up a new window.
# By remembering which devices where open before calling par() we can
# close that newly opened window immediately.
devices.before <- dev.list();
NORMAL <- 1;
BOLD <- 2;
ITALIC <- 3;
BOLDITALIC <- 4;
if (is.null(style))
return(invisible());
if (style == "default") {
par(font=NORMAL);
par(font.axis=NORMAL);
par(font.lab=NORMAL);
par(font.main=BOLD);
par(font.sub=NORMAL);
par(cex=1);
par(cex.axis=1);
par(cex.lab=1);
par(cex.main=1.2);
par(cex.sub=1);
par(col="black");
par(col.axis="black");
par(col.lab="black");
par(col.main="black");
par(col.sub="black");
par(lwd=1);
par(pch=1);
par(ps=12);
## par(tmag=1.2); ## Obsolete graphical parameter
par(mar=c(5, 4, 4, 2) + 0.1);
par(mgp=c(3, 1, 0));
par(tcl=-0.5);
setOptions(this, "bitmap", width=480, height=480, pointsize=12, quality=75);
# If there is nothing to reset, ps.options(reset=TRUE) gives an error.
options(show.error.messages=FALSE);
try(ps.options(reset=TRUE));
options(show.error.messages=TRUE);
} else if (style == "PowerPoint") {
par(font=BOLD);
par(font.axis=BOLD);
par(font.lab=BOLD);
par(font.main=BOLD);
par(font.sub=NORMAL);
par(cex=1.2);
par(cex.axis=1.2);
par(cex.lab=1.2);
par(cex.main=1.4);
par(cex.sub=1.2);
par(col="black");
par(col.axis="black");
par(col.lab="black");
par(col.main="black");
par(col.sub="black");
par(lwd=2);
par(pch=1);
par(ps=12);
## par(tmag=1.2); ## Obsolete graphical parameter
par(mar=c(4, 3, 3, 1) + 0.1);
par(mgp=c(1.5, 0.2, 0));
par(tcl=0.3);
setOptions(this, "bitmap", width=640, height=640, pointsize=14, quality=100);
setOptions(this, "postscript", width=5, height=5);
} else if (regexpr("html", style) != -1) {
par(font=NORMAL);
par(font.axis=NORMAL);
par(font.lab=NORMAL);
par(font.main=NORMAL);
par(font.sub=NORMAL);
par(cex=1.0);
par(cex.axis=1.0);
par(cex.lab=1.0);
par(cex.main=1.2);
par(cex.sub=1.0);
par(col="black");
par(col.axis="black");
par(col.lab="black");
par(col.main="black");
par(col.sub="black");
par(lwd=1);
par(pch=1);
par(ps=10);
## par(tmag=1.2); ## Obsolete graphical parameter
par(mar=c(4, 3, 3, 1) + 0.1);
par(mgp=c(1.8, 0.6, 0));
# par(mar=c(5, 4, 4, 2) + 0.1);
# par(mgp=c(3, 1, 0));
par(tcl=-0.4);
if (style == "html-80x80") {
setOptions(this, "bitmap", width=80, height=80, pointsize=8, quality=100);
} else if (style == "html-160x160") {
setOptions(this, "bitmap", width=160, height=160, pointsize=10, quality=100);
} else if (style == "html-320x320") {
setOptions(this, "bitmap", width=320, height=320, pointsize=12, quality=100);
} else if (style == "html-480x480") {
setOptions(this, "bitmap", width=480, height=480, pointsize=12, quality=100);
} else if (style == "html-640x640") {
setOptions(this, "bitmap", width=640, height=640, pointsize=12, quality=100);
} else {
setOptions(this, "bitmap", width=640, height=640, pointsize=12, quality=100);
}
setOptions(this, "postscript", width=5, height=5);
}
# Now close all new windows...
new.devices <- setdiff(dev.list(), devices.before);
if (length(new.devices) > 0)
dev.off(new.devices);
return(invisible());
}, static=TRUE);
setMethodS3("getMouseClick", "Device", function(static, device=dev.cur(), n=1, region=c("plot", "figure"), normalized=is.element(region, "figure"), ...) {
region <- match.arg(region);
Device$set(device);
xy <- locator(n);
if (identical(region, "plot")) {
if (normalized) {
# Get coordinates in [0,1]x[0,1]
usr <- par("usr");
w <- usr[2]-usr[1];
h <- usr[4]-usr[3];
xy$x <- (xy$x-usr[1])/w;
xy$y <- (xy$y-usr[3])/h;
}
} else if (identical(region, "figure")) {
# Get coordinates in plot region
usr <- par("usr");
ux <- usr[1];
uy <- usr[3];
uw <- usr[2]-ux;
uh <- usr[4]-uy;
plt <- par("plt");
px <- plt[1];
py <- plt[3];
pw <- plt[2]-px;
ph <- plt[4]-py;
ph.u <- uh/ph;
pw.u <- uw/pw;
px.u <- ux - px*pw.u;
py.u <- uy - py*ph.u;
# Get coordinates in figure region, but with the same
# units as the plot region.
fig <- par("fig");
fx <- fig[1];
fy <- fig[3];
fw <- fig[2]-fx;
fh <- fig[4]-fy;
fh.u <- ph.u/fh;
fw.u <- pw.u/fw;
fx.u <- px.u - fx*fw.u;
fy.u <- py.u - fy*fh.u;
xy$x <- xy$x - fx.u;
xy$y <- xy$y - fy.u;
if (normalized) {
# Get coordinates in [0,1]x[0,1]
xy$x <- xy$x/fw.u;
xy$y <- xy$y/fh.u;
}
}
xy;
}, static=TRUE)
setMethodS3("getDimensions", "Device", function(static, device=dev.cur(), what=c("device", "figure", "plot"), unit=c("inch"), ...) {
# Validate arguments
unit <- match.arg(unit);
what <- match.arg(what);
par <- switch(what, device="din", figure="fin", plot="pin");
# Remember active device
odev <- dev.cur();
# Query the given device
dev.set(device);
if (unit == "inch")
res <- par(par);
# Return focus to active device
dev.set(odev);
res;
})
setMethodS3("getAspectRatio", "Device", function(static, ...) {
res <- getDimensions(static, ...);
res[2]/res[1];
})
#########################################################################/**
# @RdocMethod plotSymbols
#
# @title "Display available plot symbols"
#
# \description{
# Generates a plot with all available point styles (0-255) that
# can be specified by the argument \code{pch} in almost all plot functions
# in [R]. \code{pch} can be a @vector of @integers specifying a symbol and
# @characters.}
#
# @synopsis
#
# \arguments{
# \item{interactive}{If @TRUE the user is expected to click on symbols
# whose @character value, ASCII value as an @integer, an octal decimal and
# as an hexadecimal.}
# \item{...}{Not used.}
# }
#
# \value{Returns nothing. Generates a plot.}
#
# @author
#
# \examples{
# Device$plotSymbols()
# }
#
# \seealso{
# @see "grDevices::plotmath",
# @see "graphics::par"
#
# @seeclass
# }
#*/#########################################################################
setMethodS3("plotSymbols", "Device", function(this, interactive=TRUE, ...) {
interactive <- interactive && interactive();
i <- 0:255;
ncol <-16;
top <- 3 + 2*interactive;
opar <- par(cex.axis=0.7, mar=c(3,3,top,3)+0.1)
on.exit(par(opar))
plot(i%%ncol,1+i%/%ncol, pch=i, xlim=c(0,ncol-1), xlab="", ylab="",
axes=FALSE);
axis(1, at=0:15)
axis(2, at=1:16, labels=0:15*16, las=2)
axis(3, at=0:15)
axis(4, at=1:16, labels=0:15*16+15, las=2)
if (interactive) {
title(main="Click on a symbol to add it to the data frame. Click in margin to quit!", cex.main=0.8, line=3.5);
df <- list();
usr <- par("usr");
ready <- FALSE;
while (!ready) {
click <- locator(n=1);
print(click)
x <- click$x;
y <- click$y - 1;
ready <- !(x > -0.5 && x < 15.5 && y > -0.5 && y < 15.5);
if (!ready) {
x <- round(x);
y <- round(y);
z <- 16*y + x;
ch <- intToChar(z);
dec <- as.character(z);
hex <- intToHex(z);
oct <- intToOct(z);
spc <- paste(rep("0", 2-nchar(hex)), collapse="");
hex <- paste(spc, hex, sep="");
spc <- paste(rep("0", 3-nchar(oct)), collapse="");
oct <- paste(spc, oct, sep="");
df$ch <- c(df$ch , ch );
df$dec <- c(df$dec, dec);
df$hex <- c(df$hex, hex);
df$oct <- c(df$oct, oct);
if (nchar(ch) == 0) ch <- " ";
spc <- paste(rep(" ", 3-nchar(dec)), collapse="");
dec <- paste(spc, dec, sep="");
cat("Selected ASCII character '", ch, "' ", dec, " 0x", hex,
" \\", oct, "\n", sep="");
}
}
return(df);
}
invisible();
}, static=TRUE);
#########################################################################/**
# @RdocMethod plotRegions
#
# @title "Static method plotting information about the different regions of a device"
#
# \description{
# Static method plotting the borders and displays information about the
# graphical parameters that are specifying the outer margin region, the
# figure region and the plot region.
#
# The code executed for this is the same as the example code.
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{Returns nothing.}
#
# @examples "../incl/Device.plotRegions.Rex"
#
# @author
#
# \seealso{
# @seeclass
# }
#*/#########################################################################
setMethodS3("plotRegions", "Device", function(static, ...) {
example("Device.plotRegions", package="R.graphics");
}, static=TRUE)
#########################################################################/**
# @RdocMethod choose
#
# @title "GUI figure selector"
#
# \description{
# Opens a window with a list of open figures. By clicking on any figure
# in the list, that figure is activated and brought to front.
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{Returns nothing.}
#
# @author
#
# \seealso{
# @seeclass
# }
#*/#########################################################################
setMethodS3("choose", "Device", function(static, ...) {
require(tcltk) || throw("Package tcltk is missing.");
item <- c();
count <- 0;
getSelectedItem <- function() {
as.integer(tclvalue(tkcurselection(tl))) + 1;
}
selectItem <- function(idx) {
curr <- getSelectedItem();
if (!is.na(curr))
tkselection.set(tl, curr-1);
# cat("Deselect ", curr, "\n");
tkselection.set(tl, idx-1);
# cat("Select ", idx, "\n");
# print(as.integer(tclvalue(tkcurselection(tl))) + 1);
}
onCancel <- function(...) {
tkdestroy(tt);
}
onFocus <- function(...) {
idx <- getSelectedItem();
selectedItem <- item[idx];
win <- as.integer(gsub("Figure ", "", selectedItem));
dev.set(win);
# Workaround for bug in bringToTop() R v1.7.1
missing <- setdiff(2:win,dev.list());
if (length(missing) > 0) {
for (k in missing) x11();
bringToTop(win);
for (k in missing) {
dev.set(k);
Sys.sleep(0.2);
dev.off();
}
} else {
bringToTop(win);
}
updateList();
}
onButtonRelease <- function(...) {
onFocus();
}
onUp <- function(...) {
idx <- getSelectedItem();
if (idx == 1) {
idx <- length(item);
} else {
idx <- idx - 1;
}
selectItem(idx);
onFocus();
}
onDown <- function(...) {
idx <- getSelectedItem();
if (idx == length(item)) {
idx <- 1;
} else {
idx <- idx + 1;
}
selectItem(idx);
onFocus();
}
updateList <- function(...) {
win <- dev.list();
nbrOfWin <- length(win);
item <<- paste("Figure ", win, sep="");
tkdelete(tl, 0, "end");
for (i in seq(item)) {
tkinsert(tl, "end", item[i]);
}
selectItem(which(dev.cur() == win));
}
tt <- tktoplevel();
scr <- tkscrollbar(tt, repeatinterval=5, command=function(...) {
tkyview(tl, ...);
})
tl <- tklistbox(tt, height=15, selectmode="single",
background="white", yscrollcommand=function(...) {
tkset(scr, ...);
})
tkgrid(tklabel(tt, text="Select a figure"));
tkgrid(tl, scr);
tkgrid.configure(scr, rowspan=4, sticky="nsw")
# focusButton <- tkbutton(tt, text="Focus", command=onFocus);
cancelButton <- tkbutton(tt, text="Cancel", command=onCancel);
# upButton <- tkbutton(tt, text="-", command=onUp);
# downButton <- tkbutton(tt, text="+", command=onDown);
# tkgrid(upButton, downButton, focusButton, cancelButton);
# tkbind(tt, "<KeyPress-Up>", onUp);
# tkbind(tt, "<KeyPress-Down>", onDown);
tkgrid(cancelButton);
tkbind(tl, "<ButtonRelease-1>", onButtonRelease);
updateList();
tkfocus(tt);
})
# Finally, reset the options for all device types.
#Device$resetOptions("postscript");
#Device$resetOptions("bitmap");
#Device$resetOptions("pictex");
#########################################################################/**
# @RdocMethod findPngDevice
#
# @title "Searches for a working PNG device"
#
# \description{
# @get "title".
#
# On Unix, the png device requires that X11 is available, which it is not
# when running batch scripts or running \R remotely.
#
# This method tries to create a simple png file first using the
# \code{png()} device, and if that is not working it tries the
# \code{bitmap()} device, which does not require X11 etc, because it
# utilizes Ghostscript.
# }
#
# @synopsis
#
# \arguments{
# \item{...}{Not used.}
# }
#
# \value{
# Returns the \code{png} @function, the \code{bitmap} @function, or @NULL.
# }
#
# @author
#
# \examples{
# fcn <- Device$findPngDevice();
# if (identical(fcn, png)) {
# cat("PNG device found: png()");
# } else if (identical(fcn, bitmap)) {
# cat("PNG device found: bitmap()");
# } else {
# cat("PNG device not found.");
# }
# }
#
# \seealso{
# @seeclass
# }
#*/#########################################################################
setMethodS3("findPngDevice", "Device", function(static, ...) {
file <- tempfile("hasPng");
on.exit({
if (file.exists(file))
file.remove(file);
})
# First, try png() device, if it exists...
if (capabilities("png")) {
tryCatch({
png(file);
plot(0);
dev.off();
if (file.exists(file))
return(png);
}, error = function(error) {
});
}
# Second, try bitmap() device, which utilizes ghostscript...
tryCatch({
bitmap(file);
plot(0);
dev.off();
if (file.exists(file))
return(bitmap);
}, error = function(error) {
});
# Third, try bitmap() device again, but search for ghostview first
gscmd <- System$findGhostscript();
if (is.null(gscmd))
return(NULL);
tryCatch({
bitmap(file);
plot(0);
dev.off();
if (file.exists(file))
return(bitmap);
}, error = function(error) {
});
NULL;
}, static=TRUE)
############################################################################
# HISTORY:
# 2013-02-07
# o BUG FIX: Now Device$get/setPlotParameters() uses the global
# environment to store the parameters.
# o BUG FIX: Device$setStyle() no longer tries to set graphical parameter
# 'tmag', because it is now obselete in R.
# 2010-11-28
# o BUG FIX: set() of Device tried to infer the default width and height
# from the default arguments of the device function. However, such
# defaults has been moved to options of the grDevices package.
# o Updated callFunction() for Device such that R CMD check won't complain.
# o BUG FIX: callFunction() for Device used unknown 'this' instead of
# 'static'.
# 2007-05-09
# o Now Device$findPngDevice() is using the System class in R.utils and
# not the one in R.lang (which is not there anymore).
# 2006-02-03
# o Rdoc bug fix: section 'argument' to 'arguments'.
# 2006-01-21
# o Added Rdoc comments to getParameters().
# o getParameters() now returns the image type (filename extension) in
# lower case.
# 2005-12-05
# o Added static methods Device$open() to open a device similar to print().
# o Method Device$print() now calls getParameters and callFunction()
# internally. Should work exactly the same as before.
# o Added private methods getParameters() and callFunction().
# 2005-03-07
# o Added static method findPngDevice() to Device.
# 2005-02-25
# o Added '...' arguments to all methods to please R CMD check.
# 2004-12-14
# o Added test to calculated relative width, e.g. "100%!", when height=0.
# 2004-10-21
# o Added some Rdoc comments.
# 2004-08-17
# o Added getDimensions() and getAspectRatio().
# 2004-08-02
# o BUG FIX: Device$print("xxx.eps") forgot to print with paper="special".
# This would *not* rescale the background (for instance if forced to
# "white"), but only the bounding box. This would result in a figure
# that overlapped the text in a LaTeX document.
# 2004-04-21
# o Added get-, set- and resetOptions(). This will also fix the R v1.9.0
# problem where they've "removed" .PostScript.Options, which I previously
# relied on.
# 2004-03-26
# o BUG FIX: The left and bottom click-outside-margin rules were incorrect
# for plotSymbols(interactive=TRUE).
# 2003-12-23
# o Added set- and getPrintPath(), which is now used by print(). Thus, it
# is possible to set a default output path for Device$print().
# 2003-07-18
# o Added choose().
# 2003-07-07
# o Made the Rd example for Device \dontrun{}.
# 2003-05-03
# o Now setPlotParameters() opens a new window if non is currently open.
# Solved the bugs introduced some time ago in com.braju.sma.
# 2003-04-18
# o BUG FIX: Device$print() and Device$set() did not calculate the width
# correclty if it was given as a percentage of the default width, e.g.
# "200%". It became the percentage of the height instead.
# o BUG FIX: Device$print() and Device$set() did not accept numerical
# values for width, height and pointsize. If tried, the default value
# would be used instead.
# o Update the Rdocs to make use of the new/updated Rdoc tags.
# 2003-02-21
# o Updated set() and print() to be more clever about selecting the width
# and the height if the arguments are missing etc.
# 2003-01-17
# o Added getMouseClick(), which return the (standardize [0,1]x[0,1] or
# plot) coordinates of one or several mouse click similar to locator(),
# but here the coordinates can also be relative to the window (the figure
# region) and not only to the plot region.
# 2003-01-15
# o Added bringToTop(), which basically just call bringToTop(), but got
# somewhat fancier error messages.
# 2003-01-10
# o Added arguments width and height to Device$set().
# 2003-01-07
# o Made height="100%!" the default value for Device$print().
# 2003-01-03
# o BUG FIX: Using numeric values for the width and height arguments of
# Device$print() was broken due to the changes in previous version.
# 2002-12-07
# o Now both argument 'width' and 'height' of Device$print() can be
# specifying a relative (percentage) size at the same time. It is not a
# percentage of the other axis (as it used to be), but the percentage of
# the default size. To specify the relative size to the other axis one
# has to add a "!", e.g. width="100%!", height="50%" to make the height
# 50% of the default device size and the width the same as the height.
# 2002-11-11
# o BUG FIX: The interactive mode will only take place if R is run in
# an interactive mode, i.e. if interactive() == TRUE.
# 2002-10-31
# o plotSymbols() now also has an interactive mode where one can pick
# character to a list by click on them.
# o Move plotSymbols() from Plots to this class.
# o Same for setStyle() and subplots().
# 2002-10-29
# o Added static method Device$plotRegions().
# o Rename .PlotParameters to .plotParameters *according to RCC) and made
# it an internal variable of the R.graphics environment. This required
# updating the set-/getPlotParameters() methods.
# 2002-10-28
# o Updated some of the Rdoc comments.
# o For Device$print() if only one of the 'width' and 'height' is given,
# the other one is assumed to be equal to "100%". If both are missing
# the default size according to .Bitmap.Options et al are used.
# 2002-06-24
# * BUG FIX: When R CMD check is runned .PlotParameters is not correctly
# created. Added a workaround in set-/getPlotParameter().
# 2002-05-05
# * IMPROVEMENT: If for instance on did png <- 1 and the called
# Device$print("foo.png") dev.print() would complain that 'png' is not
# a function.
# 2002-04-03
# * Added support for (R.io) File object filename specifications.
# 2002-03-30
# * Now library R.io is not needed, but R.base instead, which is hopefully
# smaller and faster to load and most likely already loaded. Added
# baseAndExtension() in R.base to deal with filename extensions.
# 2002-01-24
# * Added putTimestamp(), putAuthor() and putDataset().
# 2002-01-23
# * Update to make use of setCl assS3 and setMethodS3.
# * BUG FIX: width="50%" did not work. It was a typo and now it works.
# 2001-11-24
# * Added the static function next().
# * Now using modifiers() instead of attr().
# 2001-09-20
# * Added support for overriding the default image attribute (width, ...)
# in the Device$print() method.
# 2001-08-06
# * Device$set() will now close all intermediate device() before returning.
# * BUG FIX: Device$set() wouldn't open a new device for index=k if there
# already existed devices with index > k.
# * Added isOpen().
# 2001-07-28
# * Added Device$new().
# 2001-07-16
# * Added get- and setPlotParameters(). A first move away from the
# .lastPlot fields in MicroarrayData classes. PlotParameters should be
# globally accessable, not just from the last plotting object.
# * try-catch the error if there is nothing to reset in ps.options(reset=T).
# 2001-06-23
# * Added Rdoc comments.
# 2001-06-08
# * Added set(), which works similar to Matlab's figure().
# * Added closeAll() for simplicity. It simply calls graphics.off().
# 2001-05-14
# * Added getInternalReferences() for improving gco() performance.
# 2001-05-04
# * Now supports formal attributes.
# * Remove constructor argument and class field 'new'.
# 2001-05-01
# * Added finalize().
# 2001-04-11
# * Created from old com.braju.graphics and made into a static class, but
# changed it quite quickly into a regular class.
# 2001-03-08 [version 0.2.1]
# * Added close.screen argument to dev.close().
# 2001-03-07 [version 0.2]
# * Added restore.par argument to dev.open().
# * Added dev.close().
# 2001-02-28 [version 0.1]
# * Added Rdoc comments.
# 2001-02-12
# * Added quotaion marks around filenames in 'convert' system call.
# 2001-02-08
# * Created the gif device driver. Removed old eps2gif(); no need for it!
# * Added support for gif outputs.
# 2001-02-07
# * Created.
############################################################################
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.