Nothing
R/ggraphics.R
In gWidgetsRGtk2: Toolkit Implementation of gWidgets for RGtk2
Defines functions
as.gWidgetsRGtk2.GtkDrawingArea
as.gGd
daDrawRectangle
daGetWidthHeight
daClearRectangle
drawableToNDC
copyToClipboard
## cairo graphics device
## would like to get size from par("fin"), but this isn't so easy as it
## seems to pop up a new plot container
## pas through ... some means to control:
## rubber banding (do.rubber.banding=FALSE)
## menu popup (no_popup=TRUE)
setClass("gGraphicsRGtk",
contains="gComponentRGtk",
prototype=prototype(new("gComponentRGtk"))
)
setMethod(".ggraphics",
signature(toolkit="guiWidgetsToolkitRGtk2"),
function(toolkit,
width=dpi*6, height=dpi*6,
dpi=75, ps=12,
container=NULL,...) {
force(toolkit)
da <- gtkDrawingAreaNew()
asCairoDevice(da, pointsize=ps)
## set size
if(!is.null(width) & !is.null(height))
da$setSizeRequest(width, height)
## allow events on this widget
da$AddEvents(GdkEventMask["all-events-mask"])
obj <- as.gWidgetsRGtk2(da)
# obj = new("gGraphicsRGtk",block=da, widget=da, toolkit=toolkit)
## Woah Nelly! since 2.0.1 the device needs to be realized before we can make it
## so we put this in:
## when a device is clicked.
addhandler(obj,signal="map-event",handler = function(h, w, e, ...) {
da <- h$action
## in cairoDevice (>= 2.2.0) the device is stored in da$GetData(".devnum")
if(is.null(da$GetData(".devnum"))) {
asCairoDevice(da, pointsize=ps) # turn into cairo device
tag(obj,"device") <- da$GetData(".devnum")
}
return(TRUE) # don't propogate
}, action=da)
## handlers to raise device when clicked upon. This seems a natural way to interact with
## the device
.getDevNo <- function(da) da$getData(".devnum")
.setDevNo <- function(da, ...) {
dev.set(.getDevNo(da))
## indicate?
FALSE}
## raise when click into window
gSignalConnect(da, "button-press-event", f=.setDevNo)
## raise when motion over device -- CONFUSING, leave out
# da$addEvents(GdkEventMask['enter-notify-mask'])
# gSignalConnect(da, "enter-notify-event", f=.setDevNo)
## close device when destroyed
gSignalConnect(da, "destroy-event", f=function(da, ...) {
dev.off(.getDevNo(da))
return(FALSE)
})
## Add rubber banding
## This code is borrowed from the excellent playwith package by Felix Andrews
theArgs <- list(...)
doRubberBanding <- getWithDefault(theArgs$do.rubber.banding, TRUE)
## add environment and values to da
e <- environment()
e$dragging <- FALSE
e$x0 <- e$y0 <- e$x <- e$y <- 0
da$setData("env", e)
## need to bind drag actions: click, motion, release
if(doRubberBanding)
gSignalConnect(da, "button-press-event", function(w, e) {
if(isRightMouseClick(e))
return(FALSE)
da <- w
daClearRectangle(da)
wh <- daGetWidthHeight(da)
da.w <- wh[1]
da.h <- wh[2]
## assign("da", da, envir=.GlobalEnv)
## buf <- gdkPixbufGetFromDrawable(src=da$window, src.x=0, src.y=0,
## dest.x=0, dest.y=0, width=da.w, height=da.h)
## w$setData("buf", buf)
env <- w$getData("env")
env$x0 <- env$x <- e$x
env$y0 <- env$y <- e$y
env$dragging <- TRUE
return(FALSE)
})
if(doRubberBanding)
gSignalConnect(da, "motion-notify-event", function(w, e) {
env <- w$getData("env")
## are we dragging?
if(env$dragging) {
daClearRectangle(w)
env$x <- e$x
env$y <- e$y
## did we move enough? 10 pixels say
if(max(abs(env$x - env$x0), abs(env$y - env$y0)) > 10)
daDrawRectangle(w, env$x0, env$x, env$y0, env$y)
}
return(FALSE)
})
if(doRubberBanding)
gSignalConnect(da, "button-release-event", function(w, e) {
if(isRightMouseClick(e))
return(FALSE)
env <- w$getData("env")
## remove draggin
env$dragging <- FALSE
daClearRectangle(w) # tidy up
return(FALSE)
})
## Right mouse menu -- some means to prevent
if(is.null(theArgs$no_popup)) {
l <- list()
l$copyAction <- gaction("Copy", "Copy current graph to clipboard", icon="copy",
handler=function(h, ...) copyToClipboard(obj))
l$printAction <- gaction("Save", "Save current graph", icon="save",
handler=function(h,...) {
fname <- gfile(gettext("Filename to save to"), type="save")
if(nchar(fname)) {
if(!file.exists(fname) || gconfirm(gettext("Overwrite file?")))
svalue(obj) <- fname
}
})
.add3rdmousepopupmenu(obj, toolkit, l)
}
## Add to container if requested
if (!is.null(container)) {
if(is.logical(container) && container == TRUE)
container = gwindow()
add(container, obj, ...)
}
gSignalConnect(da, "realize", function(...) {
gdkWindowProcessAllUpdates()
while (gtkEventsPending()) gtkMainIterationDo(blocking=FALSE)
})
return(obj)
})
as.gWidgetsRGtk2.GtkDrawingArea <- function(widget,...) {
obj <- new("gGraphicsRGtk",block=widget, widget=widget,
toolkit=guiToolkit("RGtk2"))
return(obj)
}
as.gGd = function(obj) {
if(inherits(obj,"GtkDrawingArea")) {
newobj = list(ref = obj, device = obj$GetData("device"))
class(newobj) <- c("gGd", "gComponent")
return(newobj)
} else {
cat(gettext("conversion failed\n"))
return(obj)
}
}
### methods
## adding to a group is funny, we intercept here
setMethod(".add",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gGroupRGtk", value="gGraphicsRGtk"),
function(obj, toolkit, value, ...) {
getWidget(obj)$PackStart(value@block, TRUE, TRUE, 0) # expand to fill if TRUE
})
## raise this device
setReplaceMethod(".visible",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gGraphicsRGtk"),
function(obj, toolkit, ..., value) {
if(is.logical(value) == TRUE) {
da <- obj@widget
devnum <- da$GetData(".devnum")
if(!is.null(devnum))
dev.set(devnum)
}
return(obj)
})
## save Current Page
## This uses GTK -- not R to save.
## need to have window fully shown
setReplaceMethod(".svalue",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gGraphicsRGtk"),
function(obj, toolkit, index=NULL, ..., value) {
if(length(value) > 1) {
file = value$file
extension = value$extension
} else {
file = value;
extension <- strsplit(file, ".", fixed = TRUE)[[1L]]
if(n <- length(extension)) {
extension <- extension[n]
} else {
cat(gettext("No file extension given"))
return()
}
}
## check that filename is okay
if(!is.null(file) && !is.null(extension)) {
tmp = unlist(strsplit(file,"\\."))
if(tmp[length(tmp)] != extension) {
filename = Paste(file,".",extension)
} else {
filename = file
}
} else {
return()
}
da <- getWidget(obj)
wh <- daGetWidthHeight(da)
da.w <- wh[1]
da.h <- wh[2]
pixbuf <- gdkPixbufGetFromDrawable(src=da$window, src.x=0, src.y=0,
dest.x=0, dest.y=0, width=da.w, height=da.h)
out <- try(pixbuf$Save(filename = filename,type=extension), silent=TRUE)
if(inherits(out, "try-error")) {
galert(sprintf("Error in saving: %s", out), parent=obj)
}
## switch(extension,
## "ps" = dev.copy2eps.hack(file=filename,
## onefile=onefile, horizontal=horizontal,
## width=width, height = height),
## "eps" = dev.print.hack(postscript,file=filename,
## onefile=onefile, horizontal=horizontal,
## width=width, height = height),
## "pdf" = dev.print.hack(pdf,file=filename,
## onefile=onefile, horizontal=horizontal,
## width=width, height = height),
## "jpg" = dev.print.hack(jpeg,file=filename,
## onefile=onefile, horizontal=horizontal,
## width=width, height = height),
## "jpeg" = dev.print.hack(jpeg,file=filename,width=width,height=height),
## "png" = dev.print.hack(png,file=filename,width=width,height=height),
## cat("***\n Don't know this extension:", type,"\n\n")
## )
return(obj)
})
### handlers
## add this expose event for graph
setMethod(".addhandlerexpose",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gGraphicsRGtk"),
function(obj, toolkit, handler, action=NULL, ...) {
addhandler(obj,"expose-event",handler,action,...)
})
## applies a handler to the mouse click. The handler gets extra
## argument h$x, h$y passed into it. These are in [0,1] coordinates
setMethod(".addhandlerclicked",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gGraphicsRGtk"),
function(obj, toolkit, handler, action=NULL, ...) {
## handler has $obj for obj clicked on, $x, $y, $action
f = function(h,w,e,...) {
if(!isFirstMouseClick(e))
return(FALSE)
## changes to allocation storage with newer RGtk2
xclick = e$GetX()
yclick = e$GetY()
da <- getWidget(obj)
wh <- daGetWidthHeight(da)
width <- wh[1]
height <- wh[2]
x = xclick/width
y = (height - yclick)/height
## put into usr coordinates
h$x <- grconvertX(x, from="ndc", to="user")
h$y <- grconvertY(y, from="ndc", to="user")
handler(h, w, e, ...)
return(FALSE)
}
id = addhandler(obj,signal = "button-press-event",handler=f, action=action)
invisible(id)
})
## Changed handler is called after rubber band selection is updated
##
## Just click and drag out a rubber band
## The "h" list has components
## h$x for the x values in user coordinates
## h$y for the y values in user coordinates
## These can be converted as in grconvertX(h$x, from="ndc", to="user")
setMethod(".addhandlerchanged",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gGraphicsRGtk"),
function(obj, toolkit, handler, action=NULL, ...) {
da <- getWidget(obj)
ID <- gSignalConnect(da, "button-release-event", function(w, e) {
if(!isFirstMouseClick(e))
return(FALSE)
coords <- drawableToNDC(w)
h <- list(obj=obj,
action=action,
x=grconvertX(coords$x, from="ndc", to="user"),
y=grconvertY(coords$y, from="ndc", to="user"))
handler(h, ...)
return(FALSE) # propagate
})
})
## Draw a rectangle for rubber banding
daDrawRectangle <- function(da, x0, x, y0, y) {
x <- c(x0, x); y <- c(y0, y)
x0 <- min(x); x <- max(x)
y0 <- min(y); y <- max(y)
allocation = da$allocation ## GetAllocation()
da.w <- allocation$allocation$width
da.h <- allocation$allocation$height
# da.w <- da$getAllocation()$width
# da.h <- da$getAllocation()$height
## background style
gcb <- gdkGCNew(da$window)
gcb$copy(da["style"]$blackGc)
gcb$setRgbFgColor(gdkColorParse("gray50")$color)
gcb$setLineAttributes(line.width=1, line.style=GdkLineStyle["solid"],
cap.style=GdkCapStyle["butt"], join.style=GdkJoinStyle["miter"])
## foreground style
gc <- gdkGCNew(da$window)
gc$copy(da["style"]$blackGc)
gc$setRgbFgColor(gdkColorParse("black")$color)
gc$setRgbBgColor(gdkColorParse("gray50")$color)
gc$setLineAttributes(line.width=1, line.style=GdkLineStyle["double-dash"],
cap.style=GdkCapStyle["butt"], join.style=GdkJoinStyle["miter"])
gc$setDashes(c(8, 4))
## the entire rectangle to clear
rect <- as.GdkRectangle(c(x=0, y=0, width=da.w, height=da.h))
da$setData("lastRect", rect)
for (i in 1:2) {
## draw in background color first
tmp.gc <- if (i == 1) gcb else gc
gdkDrawRectangle(da$window, gc=tmp.gc, filled=FALSE, x=x0, y=y0, width=x-x0, height=y-y0)
}
gdkWindowProcessAllUpdates()
while (gtkEventsPending()) gtkMainIterationDo(blocking=FALSE)
}
## find width and height from allocation, which surprisingly seems to change from time to time
daGetWidthHeight <- function(da) {
allocation <- da$getAllocation()
## now, do we have width, height?
if("width" %in% names(allocation)) {
return(c(width=allocation$width, height=allocation$height))
} else if("allocation" %in% names(allocation)) {
return(c(width=allocation$allocation$width, height=allocation$allocation$height))
} else {
stop("Can't get width.height allocation?")
}
}
## clear all rectangles that came from rubber banding
daClearRectangle <- function(da) {
last <- da$getData("lastRect")
if(!is.null(last))
da$window$invalidateRect(last, FALSE)
gdkWindowProcessAllUpdates()
while (gtkEventsPending()) gtkMainIterationDo(blocking=FALSE)
}
## convert rectangle on drawable into NDC coordinates
drawableToNDC <- function(da) {
## convert to normalized device coordinates
e <- da$getData("env")
x.pixel <- sort(c(e$x0, e$x))
y.pixel <- sort(c(e$y0, e$y))
wh <- daGetWidthHeight(da)
da.w <- wh[1]
da.h <- wh[2]
ndc <- list(x=x.pixel/da.w, y= 1- rev(y.pixel/da.h))
return(ndc)
}
## copy graphic to clipboard for cut-and-paste
##
## I can't seem to bind this to ctrl-c (or some such), as I can't get key-press-event
## to work on tihs widget. Here as an example:
## http://ruby-gnome2.sourceforge.jp/hiki.cgi?tut-gtk2-agtkw-draww
## da['can-focus'] <- TRUE; da$addEvents(GdkEventMask["key-press-mask"]) were tried
## @param da either the drawable object (from a callback say) or the ggraphics object.
copyToClipboard <- function(da) {
if(!is(da, "GtkDrawingArea"))
da <- getWidget(da) # ggraphics object
da.w <- da$getAllocation()$width
da.h <- da$getAllocation()$height
buf <- gdkPixbufGetFromDrawable(src=da$window, src.x=0, src.y=0,
dest.x=0, dest.y=0, width=da.w, height=da.h)
gtkClipboardGet("CLIPBOARD")$setImage(buf)
}
##################################################
##
## dev.print and dev.copy2eps have a test on the device that needs Cairo added to it
devPrintHack = function (device = postscript, ...)
{
current.device <- dev.cur()
nm <- names(current.device)[1]
if (nm == "null device")
stop("no device to print from")
if (!(nm %in% c("Cairo", "X11", "GTK", "gnome", "windows", "quartz")))
stop("can only print from screen device")
oc <- match.call()
print(oc)
oc[[1]] <- as.name("dev.copy")
oc$device <- device
din <- par("din")
w <- din[1]
h <- din[2]
if (missing(device)) {
if (is.null(oc$file))
oc$file <- ""
hz0 <- oc$horizontal
hz <- if (is.null(hz0))
ps.options()$horizontal
else eval.parent(hz0)
paper <- oc$paper
if (is.null(paper))
paper <- ps.options()$paper
if (paper == "default")
paper <- getOption("papersize")
paper <- tolower(paper)
switch(paper, a4 = {
wp <- 8.27
hp <- 11.69
}, legal = {
wp <- 8.5
hp <- 14
}, executive = {
wp <- 7.25
hp <- 10.5
}, {
wp <- 8.5
hp <- 11
})
wp <- wp - 0.5
hp <- hp - 0.5
if (!hz && is.null(hz0) && h < wp && wp < w && w < hp) {
hz <- TRUE
}
else if (hz && is.null(hz0) && w < wp && wp < h && h <
hp) {
hz <- FALSE
}
else {
h0 <- ifelse(hz, wp, hp)
if (h > h0) {
w <- w * h0/h
h <- h0
}
w0 <- ifelse(hz, hp, wp)
if (w > w0) {
h <- h * w0/w
w <- w0
}
}
if (is.null(oc$pointsize)) {
pt <- ps.options()$pointsize
oc$pointsize <- pt * w/din[1]
}
if (is.null(hz0))
oc$horizontal <- hz
if (is.null(oc$width))
oc$width <- w
if (is.null(oc$height))
oc$height <- h
}
else {
devname <- deparse(substitute(device))
if (devname %in% c("png", "jpeg", "bmp") && is.null(oc$width) &&
is.null(oc$height))
warning("need to specify one of 'width' and 'height'")
if (is.null(oc$width))
oc$width <- if (!is.null(oc$height))
w/h * eval.parent(oc$height)
else w
if (is.null(oc$height))
oc$height <- if (!is.null(oc$width))
h/w * eval.parent(oc$width)
else h
}
dev.off(eval.parent(oc))
dev.set(current.device)
}
dev.copy2eps.hack = function (...)
{
current.device <- dev.cur()
nm <- names(current.device)[1]
if (nm == "null device")
stop("no device to print from")
if (!(nm %in% c("Cairo","X11", "GTK", "gnome", "windows", "quartz")))
stop("can only print from screen device")
oc <- match.call()
oc[[1]] <- as.name("dev.copy")
oc$device <- postscript
oc$onefile <- FALSE
oc$horizontal <- FALSE
if (is.null(oc$paper))
oc$paper <- "special"
din <- par("din")
w <- din[1]
h <- din[2]
if (is.null(oc$width))
oc$width <- if (!is.null(oc$height))
w/h * eval.parent(oc$height)
else w
if (is.null(oc$height))
oc$height <- if (!is.null(oc$width))
h/w * eval.parent(oc$width)
else h
if (is.null(oc$file))
oc$file <- "Rplot.eps"
dev.off(eval.parent(oc))
dev.set(current.device)
}
Try the gWidgetsRGtk2 package in your browser
Any scripts or data that you put into this service are public.
gWidgetsRGtk2 documentation built on May 2, 2019, 5:58 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 as.gWidgetsRGtk2.GtkDrawingArea as.gGd daDrawRectangle daGetWidthHeight daClearRectangle drawableToNDC copyToClipboard
## cairo graphics device
## would like to get size from par("fin"), but this isn't so easy as it
## seems to pop up a new plot container
## pas through ... some means to control:
## rubber banding (do.rubber.banding=FALSE)
## menu popup (no_popup=TRUE)
setClass("gGraphicsRGtk",
contains="gComponentRGtk",
prototype=prototype(new("gComponentRGtk"))
)
setMethod(".ggraphics",
signature(toolkit="guiWidgetsToolkitRGtk2"),
function(toolkit,
width=dpi*6, height=dpi*6,
dpi=75, ps=12,
container=NULL,...) {
force(toolkit)
da <- gtkDrawingAreaNew()
asCairoDevice(da, pointsize=ps)
## set size
if(!is.null(width) & !is.null(height))
da$setSizeRequest(width, height)
## allow events on this widget
da$AddEvents(GdkEventMask["all-events-mask"])
obj <- as.gWidgetsRGtk2(da)
# obj = new("gGraphicsRGtk",block=da, widget=da, toolkit=toolkit)
## Woah Nelly! since 2.0.1 the device needs to be realized before we can make it
## so we put this in:
## when a device is clicked.
addhandler(obj,signal="map-event",handler = function(h, w, e, ...) {
da <- h$action
## in cairoDevice (>= 2.2.0) the device is stored in da$GetData(".devnum")
if(is.null(da$GetData(".devnum"))) {
asCairoDevice(da, pointsize=ps) # turn into cairo device
tag(obj,"device") <- da$GetData(".devnum")
}
return(TRUE) # don't propogate
}, action=da)
## handlers to raise device when clicked upon. This seems a natural way to interact with
## the device
.getDevNo <- function(da) da$getData(".devnum")
.setDevNo <- function(da, ...) {
dev.set(.getDevNo(da))
## indicate?
FALSE}
## raise when click into window
gSignalConnect(da, "button-press-event", f=.setDevNo)
## raise when motion over device -- CONFUSING, leave out
# da$addEvents(GdkEventMask['enter-notify-mask'])
# gSignalConnect(da, "enter-notify-event", f=.setDevNo)
## close device when destroyed
gSignalConnect(da, "destroy-event", f=function(da, ...) {
dev.off(.getDevNo(da))
return(FALSE)
})
## Add rubber banding
## This code is borrowed from the excellent playwith package by Felix Andrews
theArgs <- list(...)
doRubberBanding <- getWithDefault(theArgs$do.rubber.banding, TRUE)
## add environment and values to da
e <- environment()
e$dragging <- FALSE
e$x0 <- e$y0 <- e$x <- e$y <- 0
da$setData("env", e)
## need to bind drag actions: click, motion, release
if(doRubberBanding)
gSignalConnect(da, "button-press-event", function(w, e) {
if(isRightMouseClick(e))
return(FALSE)
da <- w
daClearRectangle(da)
wh <- daGetWidthHeight(da)
da.w <- wh[1]
da.h <- wh[2]
## assign("da", da, envir=.GlobalEnv)
## buf <- gdkPixbufGetFromDrawable(src=da$window, src.x=0, src.y=0,
## dest.x=0, dest.y=0, width=da.w, height=da.h)
## w$setData("buf", buf)
env <- w$getData("env")
env$x0 <- env$x <- e$x
env$y0 <- env$y <- e$y
env$dragging <- TRUE
return(FALSE)
})
if(doRubberBanding)
gSignalConnect(da, "motion-notify-event", function(w, e) {
env <- w$getData("env")
## are we dragging?
if(env$dragging) {
daClearRectangle(w)
env$x <- e$x
env$y <- e$y
## did we move enough? 10 pixels say
if(max(abs(env$x - env$x0), abs(env$y - env$y0)) > 10)
daDrawRectangle(w, env$x0, env$x, env$y0, env$y)
}
return(FALSE)
})
if(doRubberBanding)
gSignalConnect(da, "button-release-event", function(w, e) {
if(isRightMouseClick(e))
return(FALSE)
env <- w$getData("env")
## remove draggin
env$dragging <- FALSE
daClearRectangle(w) # tidy up
return(FALSE)
})
## Right mouse menu -- some means to prevent
if(is.null(theArgs$no_popup)) {
l <- list()
l$copyAction <- gaction("Copy", "Copy current graph to clipboard", icon="copy",
handler=function(h, ...) copyToClipboard(obj))
l$printAction <- gaction("Save", "Save current graph", icon="save",
handler=function(h,...) {
fname <- gfile(gettext("Filename to save to"), type="save")
if(nchar(fname)) {
if(!file.exists(fname) || gconfirm(gettext("Overwrite file?")))
svalue(obj) <- fname
}
})
.add3rdmousepopupmenu(obj, toolkit, l)
}
## Add to container if requested
if (!is.null(container)) {
if(is.logical(container) && container == TRUE)
container = gwindow()
add(container, obj, ...)
}
gSignalConnect(da, "realize", function(...) {
gdkWindowProcessAllUpdates()
while (gtkEventsPending()) gtkMainIterationDo(blocking=FALSE)
})
return(obj)
})
as.gWidgetsRGtk2.GtkDrawingArea <- function(widget,...) {
obj <- new("gGraphicsRGtk",block=widget, widget=widget,
toolkit=guiToolkit("RGtk2"))
return(obj)
}
as.gGd = function(obj) {
if(inherits(obj,"GtkDrawingArea")) {
newobj = list(ref = obj, device = obj$GetData("device"))
class(newobj) <- c("gGd", "gComponent")
return(newobj)
} else {
cat(gettext("conversion failed\n"))
return(obj)
}
}
### methods
## adding to a group is funny, we intercept here
setMethod(".add",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gGroupRGtk", value="gGraphicsRGtk"),
function(obj, toolkit, value, ...) {
getWidget(obj)$PackStart(value@block, TRUE, TRUE, 0) # expand to fill if TRUE
})
## raise this device
setReplaceMethod(".visible",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gGraphicsRGtk"),
function(obj, toolkit, ..., value) {
if(is.logical(value) == TRUE) {
da <- obj@widget
devnum <- da$GetData(".devnum")
if(!is.null(devnum))
dev.set(devnum)
}
return(obj)
})
## save Current Page
## This uses GTK -- not R to save.
## need to have window fully shown
setReplaceMethod(".svalue",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gGraphicsRGtk"),
function(obj, toolkit, index=NULL, ..., value) {
if(length(value) > 1) {
file = value$file
extension = value$extension
} else {
file = value;
extension <- strsplit(file, ".", fixed = TRUE)[[1L]]
if(n <- length(extension)) {
extension <- extension[n]
} else {
cat(gettext("No file extension given"))
return()
}
}
## check that filename is okay
if(!is.null(file) && !is.null(extension)) {
tmp = unlist(strsplit(file,"\\."))
if(tmp[length(tmp)] != extension) {
filename = Paste(file,".",extension)
} else {
filename = file
}
} else {
return()
}
da <- getWidget(obj)
wh <- daGetWidthHeight(da)
da.w <- wh[1]
da.h <- wh[2]
pixbuf <- gdkPixbufGetFromDrawable(src=da$window, src.x=0, src.y=0,
dest.x=0, dest.y=0, width=da.w, height=da.h)
out <- try(pixbuf$Save(filename = filename,type=extension), silent=TRUE)
if(inherits(out, "try-error")) {
galert(sprintf("Error in saving: %s", out), parent=obj)
}
## switch(extension,
## "ps" = dev.copy2eps.hack(file=filename,
## onefile=onefile, horizontal=horizontal,
## width=width, height = height),
## "eps" = dev.print.hack(postscript,file=filename,
## onefile=onefile, horizontal=horizontal,
## width=width, height = height),
## "pdf" = dev.print.hack(pdf,file=filename,
## onefile=onefile, horizontal=horizontal,
## width=width, height = height),
## "jpg" = dev.print.hack(jpeg,file=filename,
## onefile=onefile, horizontal=horizontal,
## width=width, height = height),
## "jpeg" = dev.print.hack(jpeg,file=filename,width=width,height=height),
## "png" = dev.print.hack(png,file=filename,width=width,height=height),
## cat("***\n Don't know this extension:", type,"\n\n")
## )
return(obj)
})
### handlers
## add this expose event for graph
setMethod(".addhandlerexpose",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gGraphicsRGtk"),
function(obj, toolkit, handler, action=NULL, ...) {
addhandler(obj,"expose-event",handler,action,...)
})
## applies a handler to the mouse click. The handler gets extra
## argument h$x, h$y passed into it. These are in [0,1] coordinates
setMethod(".addhandlerclicked",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gGraphicsRGtk"),
function(obj, toolkit, handler, action=NULL, ...) {
## handler has $obj for obj clicked on, $x, $y, $action
f = function(h,w,e,...) {
if(!isFirstMouseClick(e))
return(FALSE)
## changes to allocation storage with newer RGtk2
xclick = e$GetX()
yclick = e$GetY()
da <- getWidget(obj)
wh <- daGetWidthHeight(da)
width <- wh[1]
height <- wh[2]
x = xclick/width
y = (height - yclick)/height
## put into usr coordinates
h$x <- grconvertX(x, from="ndc", to="user")
h$y <- grconvertY(y, from="ndc", to="user")
handler(h, w, e, ...)
return(FALSE)
}
id = addhandler(obj,signal = "button-press-event",handler=f, action=action)
invisible(id)
})
## Changed handler is called after rubber band selection is updated
##
## Just click and drag out a rubber band
## The "h" list has components
## h$x for the x values in user coordinates
## h$y for the y values in user coordinates
## These can be converted as in grconvertX(h$x, from="ndc", to="user")
setMethod(".addhandlerchanged",
signature(toolkit="guiWidgetsToolkitRGtk2",obj="gGraphicsRGtk"),
function(obj, toolkit, handler, action=NULL, ...) {
da <- getWidget(obj)
ID <- gSignalConnect(da, "button-release-event", function(w, e) {
if(!isFirstMouseClick(e))
return(FALSE)
coords <- drawableToNDC(w)
h <- list(obj=obj,
action=action,
x=grconvertX(coords$x, from="ndc", to="user"),
y=grconvertY(coords$y, from="ndc", to="user"))
handler(h, ...)
return(FALSE) # propagate
})
})
## Draw a rectangle for rubber banding
daDrawRectangle <- function(da, x0, x, y0, y) {
x <- c(x0, x); y <- c(y0, y)
x0 <- min(x); x <- max(x)
y0 <- min(y); y <- max(y)
allocation = da$allocation ## GetAllocation()
da.w <- allocation$allocation$width
da.h <- allocation$allocation$height
# da.w <- da$getAllocation()$width
# da.h <- da$getAllocation()$height
## background style
gcb <- gdkGCNew(da$window)
gcb$copy(da["style"]$blackGc)
gcb$setRgbFgColor(gdkColorParse("gray50")$color)
gcb$setLineAttributes(line.width=1, line.style=GdkLineStyle["solid"],
cap.style=GdkCapStyle["butt"], join.style=GdkJoinStyle["miter"])
## foreground style
gc <- gdkGCNew(da$window)
gc$copy(da["style"]$blackGc)
gc$setRgbFgColor(gdkColorParse("black")$color)
gc$setRgbBgColor(gdkColorParse("gray50")$color)
gc$setLineAttributes(line.width=1, line.style=GdkLineStyle["double-dash"],
cap.style=GdkCapStyle["butt"], join.style=GdkJoinStyle["miter"])
gc$setDashes(c(8, 4))
## the entire rectangle to clear
rect <- as.GdkRectangle(c(x=0, y=0, width=da.w, height=da.h))
da$setData("lastRect", rect)
for (i in 1:2) {
## draw in background color first
tmp.gc <- if (i == 1) gcb else gc
gdkDrawRectangle(da$window, gc=tmp.gc, filled=FALSE, x=x0, y=y0, width=x-x0, height=y-y0)
}
gdkWindowProcessAllUpdates()
while (gtkEventsPending()) gtkMainIterationDo(blocking=FALSE)
}
## find width and height from allocation, which surprisingly seems to change from time to time
daGetWidthHeight <- function(da) {
allocation <- da$getAllocation()
## now, do we have width, height?
if("width" %in% names(allocation)) {
return(c(width=allocation$width, height=allocation$height))
} else if("allocation" %in% names(allocation)) {
return(c(width=allocation$allocation$width, height=allocation$allocation$height))
} else {
stop("Can't get width.height allocation?")
}
}
## clear all rectangles that came from rubber banding
daClearRectangle <- function(da) {
last <- da$getData("lastRect")
if(!is.null(last))
da$window$invalidateRect(last, FALSE)
gdkWindowProcessAllUpdates()
while (gtkEventsPending()) gtkMainIterationDo(blocking=FALSE)
}
## convert rectangle on drawable into NDC coordinates
drawableToNDC <- function(da) {
## convert to normalized device coordinates
e <- da$getData("env")
x.pixel <- sort(c(e$x0, e$x))
y.pixel <- sort(c(e$y0, e$y))
wh <- daGetWidthHeight(da)
da.w <- wh[1]
da.h <- wh[2]
ndc <- list(x=x.pixel/da.w, y= 1- rev(y.pixel/da.h))
return(ndc)
}
## copy graphic to clipboard for cut-and-paste
##
## I can't seem to bind this to ctrl-c (or some such), as I can't get key-press-event
## to work on tihs widget. Here as an example:
## http://ruby-gnome2.sourceforge.jp/hiki.cgi?tut-gtk2-agtkw-draww
## da['can-focus'] <- TRUE; da$addEvents(GdkEventMask["key-press-mask"]) were tried
## @param da either the drawable object (from a callback say) or the ggraphics object.
copyToClipboard <- function(da) {
if(!is(da, "GtkDrawingArea"))
da <- getWidget(da) # ggraphics object
da.w <- da$getAllocation()$width
da.h <- da$getAllocation()$height
buf <- gdkPixbufGetFromDrawable(src=da$window, src.x=0, src.y=0,
dest.x=0, dest.y=0, width=da.w, height=da.h)
gtkClipboardGet("CLIPBOARD")$setImage(buf)
}
##################################################
##
## dev.print and dev.copy2eps have a test on the device that needs Cairo added to it
devPrintHack = function (device = postscript, ...)
{
current.device <- dev.cur()
nm <- names(current.device)[1]
if (nm == "null device")
stop("no device to print from")
if (!(nm %in% c("Cairo", "X11", "GTK", "gnome", "windows", "quartz")))
stop("can only print from screen device")
oc <- match.call()
print(oc)
oc[[1]] <- as.name("dev.copy")
oc$device <- device
din <- par("din")
w <- din[1]
h <- din[2]
if (missing(device)) {
if (is.null(oc$file))
oc$file <- ""
hz0 <- oc$horizontal
hz <- if (is.null(hz0))
ps.options()$horizontal
else eval.parent(hz0)
paper <- oc$paper
if (is.null(paper))
paper <- ps.options()$paper
if (paper == "default")
paper <- getOption("papersize")
paper <- tolower(paper)
switch(paper, a4 = {
wp <- 8.27
hp <- 11.69
}, legal = {
wp <- 8.5
hp <- 14
}, executive = {
wp <- 7.25
hp <- 10.5
}, {
wp <- 8.5
hp <- 11
})
wp <- wp - 0.5
hp <- hp - 0.5
if (!hz && is.null(hz0) && h < wp && wp < w && w < hp) {
hz <- TRUE
}
else if (hz && is.null(hz0) && w < wp && wp < h && h <
hp) {
hz <- FALSE
}
else {
h0 <- ifelse(hz, wp, hp)
if (h > h0) {
w <- w * h0/h
h <- h0
}
w0 <- ifelse(hz, hp, wp)
if (w > w0) {
h <- h * w0/w
w <- w0
}
}
if (is.null(oc$pointsize)) {
pt <- ps.options()$pointsize
oc$pointsize <- pt * w/din[1]
}
if (is.null(hz0))
oc$horizontal <- hz
if (is.null(oc$width))
oc$width <- w
if (is.null(oc$height))
oc$height <- h
}
else {
devname <- deparse(substitute(device))
if (devname %in% c("png", "jpeg", "bmp") && is.null(oc$width) &&
is.null(oc$height))
warning("need to specify one of 'width' and 'height'")
if (is.null(oc$width))
oc$width <- if (!is.null(oc$height))
w/h * eval.parent(oc$height)
else w
if (is.null(oc$height))
oc$height <- if (!is.null(oc$width))
h/w * eval.parent(oc$width)
else h
}
dev.off(eval.parent(oc))
dev.set(current.device)
}
dev.copy2eps.hack = function (...)
{
current.device <- dev.cur()
nm <- names(current.device)[1]
if (nm == "null device")
stop("no device to print from")
if (!(nm %in% c("Cairo","X11", "GTK", "gnome", "windows", "quartz")))
stop("can only print from screen device")
oc <- match.call()
oc[[1]] <- as.name("dev.copy")
oc$device <- postscript
oc$onefile <- FALSE
oc$horizontal <- FALSE
if (is.null(oc$paper))
oc$paper <- "special"
din <- par("din")
w <- din[1]
h <- din[2]
if (is.null(oc$width))
oc$width <- if (!is.null(oc$height))
w/h * eval.parent(oc$height)
else w
if (is.null(oc$height))
oc$height <- if (!is.null(oc$width))
h/w * eval.parent(oc$width)
else h
if (is.null(oc$file))
oc$file <- "Rplot.eps"
dev.off(eval.parent(oc))
dev.set(current.device)
}
Try the gWidgetsRGtk2 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.