#qtbase v 0.8-4
#qtpaint v 0.7.9
#svn 425
library(qtpaint)
#####################################################################
###In-progress Example###
##may not run
###End in progress###
####################################################################
######################################################################
###Example###
##not run!
#library(plumbr)
#source(".../api_0.1-2.R")
##data
#n<-10000
#x<-rnorm(n,50,25)
#y<-rnorm(n,50,25)
#df1<-mutaframe(X=x,Y=y)
#width<-400
#height<-400
#rectW<-2
#rectH<-2
#axes <- function(item, painter) {
# qfont(painter) <- qfont(pointsize=12)
# pos <- as.matrix(item$geometry) + 5
# qdrawText(painter, colnames(df1)[1], pos[2], pos[4], "right", "bottom")
# qdrawText(painter, colnames(df1)[2], pos[1], pos[3], "left", "top")
#}
#
#plot1<-new_plot(width,height,xrange=range(df1[,1]),yrange=range(df1[,2]))
#
#mark<- glyph(left=df1[,1]-min(df1[,1]),bottom=df1[,2]-min(df1[,2]),stroke=NA,fill='black',size=5,parent=plot1)
#mark2<-rect(left=df1[,1]-(0.5*rectW)-min(df1[,1]),bottom=df1[,2]- (0.5*rectH)- min(df1[,2]),height=rectH, width=rectW,stroke=NA,fill=col2rgb(rgb(1,seq(0,1,length=nrow(df1)),0,0.5),T),parent=plot1)
#mark3<-line(left=50+c(1:90)*sin(6*pi*c(1:90)/100)-min(df1[,1]),bottom=50+c(1:90)*cos(6*pi*c(1:90)/100)-min(df1[,2]),stroke="blue",width=3,parent=plot1)
#mark4<-hbar(bottom=50-min(df1[,2]),left=c(-9,59)-min(df1[,1]),right=c(29,96)-min(df1[,2]),parent=plot1)
#mark5<-vbar(left=50-min(df1[,1]),bottom=c(-33,83)-min(df1[,2]),top=c(0,115)-min(df1[,2]),parent=plot1, stroke="blue")
#mark6<-text(bottom=50-min(df1[,2]),left=50-min(df1[,1]),text="test",parent=plot1)
#
#add_layer(parent=plot1,mark=mark)
#add_layer(parent=plot1,mark=mark2)
#add_layer(parent=plot1,mark=mark3)
#add_layer(parent=plot1,mark=mark4)
#add_layer(parent=plot1,mark=mark5)
#add_layer(parent=plot1,mark=mark6)
#view <- qplotView(scene = plot1$scene)
#overlay<-view$overlay()
#axesOverlay<-qlayer(overlay,axes)
#print(view)
#modify_layer(layerID=1,parent=plot1,show=F)
#modify_layer(layerID=1,parent=plot1,show=T)
#modify_layer(layerID=3,parent=plot1,alpha=0.3)
#modify_layer(layerID=6,parent=plot1,shift_right=200)
###End Example###
######################################################################
######################################################################
###Mark Constructors###
# inspired from protovis
# arguments are in data units unless otherwise specified
#Reference from protovis
# protovis object: dot
# reference: http://vis.stanford.edu/protovis/docs/dot.html
# minimum properties: left & bottom
# top - the distance from the top edge of the parent panel to the dot center.
# left - the distance from the left edge of the parent panel to the dot center.
# bottom - the distance from the bottom edge of the parent panel to the dot center.
# right - the distance from the right edge of the parent panel to the dot center.
# size - the size (proportional to area) of the dot. NOTE: see changes below
#Changes/Additions from protovis
# xrange - (xmin,xmax) of parent panel
# yrange - (ymin,ymax) of parent panel
# size - radius
# stroke - color of glyph outline
# fill - color to fill glyph
glyph <- function(top = NULL, left = NULL, bottom = NULL, right = NULL, fill = "black", stroke = NA, size= 5,parent=NULL) {
#error handling
#need one each of left/right; top/bottom
if( (is.null(left) & is.null(right)) |
(is.null(top) & is.null(bottom)) |
(!is.null(left) & !is.null(right)) |
(!is.null(top) & !is.null(bottom))) {
print("incorrect arguments: need one each of left/right and top/bottom")
}
structure(list(left = left,right=right,top=top, bottom = bottom,fill = fill, stroke = stroke,size=size,parent=parent), class = c("cranvas", "glyph"))
}
#Reference from protovis:
# protovis object - bar
# reference - http://vis.stanford.edu/protovis/docs/bar.html
# minimum properties: left,bottom, width, height
# top - the distance from the top edge of the parent panel.
# left - the distance from the left edge of the parent panel.
# bottom - the distance from the bottom edge of the parent panel.
# right - the distance from the right edge of the parent panel.
# width - the width of the bar.
# height - the height of the bar
#Changes/Additions from protovis:
# xrange - (xmin,xmax) of parent panel
# yrange - (ymin,ymax) of parent panel
# fill - color to fill rect
# stroke - color of rect outline
#Comments:
## Do we really need to modify arguments to support protovis naming conventions only to modify them again to support qtpaint property conventions?
## Wouldn't it be easier to have qtpaint support property conventions? Note this question does not address superficial naming conventions, rather
## observing that protovis defines the shape using width and height properties. qdrawRect explicitly uses left right top bottom.
rect <- function(left = NULL,right=NULL,top=NULL, bottom = NULL, width=NULL, height=NULL,fill = "black", stroke = NULL,parent=NULL) {
if( (is.null(left) & is.null(right)) |
(is.null(right) & is.null(width)) |
(is.null(left) & is.null(width)) |
(!is.null(left) & !is.null(right) & !is.null(width))|
(is.null(top) & is.null(bottom)) |
(is.null(top) & is.null(height)) |
(is.null(bottom) & is.null(height)) |
(!is.null(top) & !is.null(bottom) & !is.null(height))) {
print("need 2 of 3 in *left,right,width* and *top,bottom,height*")
}
structure(list(left = left, bottom = bottom, right = right, top = top, height =height, width = width, parent = parent, fill = fill, stroke = stroke), class = c("cranvas", "rect"))
}
#Reference from protovis:
# protovis object - line
# reference - http://vis.stanford.edu/protovis/docs/line.html
# minimum properties: left, bottom
# top - the distance from the top edge of the parent panel to the line center.NOTE: see changes below
# left - the distance from the left edge of the parent panel to the line center.NOTE: see changes below
# bottom - the distance from the bottom edge of the parent panel to the line center.NOTE: see changes below
# right - the distance from the right edge of the parent panel to the line center.NOTE: see changes below
# defining the top property instead of bottom, the line is flipped vertically:
# using right instead of left flips horizontally
#Changes/Additions from protovis:
# top,left,bottom,right measure distance to segment endpoints #like specs for provis rule (see below)
line <- function(left = NULL,right=NULL,top=NULL, bottom = NULL,stroke = "black", width=1,parent=NULL) {
if( ( !is.null(left) & !is.null(right) ) |
( is.null(left) & is.null(right) ) |
( !is.null(top) & !is.null(bottom) ) |
( is.null(top) & is.null(bottom) ) ) {
print("need one of {top,bottom} and {left,right}")
}
structure(list(left = left,right=right, top=top,bottom = bottom, stroke = stroke, width=width,parent=parent), class = c("cranvas", "line"))
}
#Reference from protovis:
# protovis object - rule
# reference - http://vis.stanford.edu/protovis/docs/rule.html
# minimum properties:
# horizontal, entire width -bottom
# horizontal, specified width - bottom, left right
# vertical, full height - left
# vertical, specified height - left, top, bottom
hbar <- function(width = 1,top=NULL, bottom = NULL, left = NULL, right=NULL,stroke = 'black',parent=parent) {
if( !is.null(top) & !is.null(bottom) ) {
print( "need only one of {top,bottom}" )
}
if ( ( !is.null(left) & is.null(right) ) |
( is.null(left) & !is.null(left) ) ) {
print( "need both left and right")
}
structure( list( left=left, right=right, top=top, bottom=bottom, stroke=stroke, width=width, parent=parent), class = c("cranvas", "hbar"))
}
vbar <- function(left = NULL, right = NULL, top = NULL, bottom = NULL, stroke = 'black', width=1, parent=NULL) {
if( !is.null(left) & !is.null(right) ) {
print( "need only one of {left,right}" )
}
if ( ( !is.null(top) & is.null(bottom) ) |
( is.null(top) & !is.null(bottom) ) ) {
print( "need both top and bottom" )
}
structure( list( left=left, right=right, top=top, bottom=bottom, stroke=stroke, width=width, parent=parent), class = c("cranvas", "vbar"))
}
#Reference from protovis:
# protovis object - labels
# reference - http://vis.stanford.edu/protovis/docs/label.html
# minimum properties: left, bottom, text
# top - the distance from the top edge of the parent panel to the text anchor.
# left - the distance from the left edge of the parent panel to the text anchor.
# bottom - the distance from the bottom edge of the parent panel to the text anchor.
# right - the distance from the right edge of the parent panel to the text anchor.
# textAlign - horizontal alignment.
# textBaseline - vertical alignment.
# textMargin - margin to offset from the text anchor.
# textAngle - rotation angle, in radians.
text <- function(top = NULL, left = NULL, bottom = NULL, right = NULL, text = NULL, stroke = "black", valign = "center", halign = "center", rot = 0, margin = NULL, font = "Arial", italic = F, pointsize = 12, parent = NULL){
if( ( is.null(left) & is.null(right) ) |
( !is.null(left) & !is.null(right) ) |
( is.null(top) & is.null(bottom) ) |
( !is.null(top) & !is.null(bottom) ) ) {
print( "need one of {left,right} and {top,bottom}" )
}
structure( list( top = top, left = left, bottom = bottom, right = right, text = text, stroke = stroke, valign = valign, halign = halign, rot = rot, margin = margin, font = font, italic = italic, pointsize = pointsize, parent = parent), class = c("cranvas", "text") )
}
###End Mark Constructors###
######################################################################
#####################################################################
###Draw Wrappers###
# Thin wrappers around qtpaint drawing functions that basically translate
# argument names. (And maybe wrap around any qtpaints that need to be
# temporarily worked around).
draw <- function(mark, canvas) UseMethod("draw")
draw.glyph <- function(mark, canvas) {
if (is.null(mark$left) & !is.null(mark$right)) {
x <- mark$parent$limits$width() - mark$right
} else {
x <- mark$left
}
if (is.null(mark$bottom) & !is.null(mark$top)){
y <- mark$parent$limits$height() - mark$top
} else {
y <- mark$bottom
}
x<-x + mark$parent$limits$left()
y<-y + mark$parent$limits$top()
circle <- qglyphCircle(r=mark$size)
qdrawGlyph(canvas, circle, x=x, y=y,stroke = mark$stroke, fill = mark$fill)
}
draw.rect <- function(mark, canvas) {
if(!is.null(mark$left) & !is.null(mark$width)) {
xleft <- mark$left
xright <- mark$left + mark$width
} else if (!is.null(mark$right) & !is.null(mark$width)) {
xleft <- mark$parent$limits$width() - mark$right - mark$width
xright <- xleft + mark$width
} else {
xleft <- mark$left
xright <- mark$left + ( mark$parent$limits$width() - mark$left - mark$right )
}
if(!is.null(mark$bottom) & !is.null(mark$height)) {
ybottom <- mark$bottom
ytop <- mark$bottom + mark$height
} else if (!is.null(mark$top) & !is.null(mark$height)) {
ybottom <-mark$parent$limits$height() - mark$top - mark$height
ytop<- ybottom + mark$height
} else {
ybottom <- mark$bottom
ytop<- mark$bottom + ( mark$parent$limits$height() - mark$bottom - mark$top )
}
xleft <- xleft + mark$parent$limits$left()
xright <- xright + mark$parent$limits$left()
ytop <- ytop + mark$parent$limits$top()
ybottom <- ybottom + mark$parent$limits$top()
qdrawRect(p=canvas, xleft=xleft, ybottom, xright, ytop,stroke = mark$stroke, fill = mark$fill)
}
draw.line <- function(mark, canvas) {
if( !is.null(mark$left) ){
x <- mark$left
} else {
x <- sum(range(mark$right)) - mark$right
}
if( !is.null(mark$bottom) ){
y <- mark$bottom
} else {
y <- sum(range(mark$top)) - mark$top
}
x <- x + mark$parent$limits$left()
y <- y + mark$parent$limits$top()
qlineWidth(canvas) <- mark$width
qdrawLine(canvas, x, y, stroke = mark$stroke)
}
draw.hbar <- function(mark,canvas) {
if( is.null(mark$left) ) {
temp <- vector (mode = "numeric", length = max(length(mark$top), length(mark$bottom)) * 3)
for (i in 1:(length(temp)/3) ) {
temp[3 * i - 2] <- mark$parent$limits$left()
temp[3 * i - 1] <- mark$parent$limits$right()
temp[3 * i] <- NA
}
x <- temp
} else {
temp <- vector( mode="numeric", length=length(mark$left) * 3 )
for ( i in 1:length(mark$left) ) {
temp[3 * i - 2] <- mark$left[i]
temp[3 * i - 1] <- mark$parent$limits$width() - mark$right[i]
temp[3 * i] <- NA
}
x <- temp
x <- x + mark$parent$limits$left()
}
if( !is.null(mark$bottom) ) {
temp <- vector( mode = "numeric", length = length(mark$bottom) * 3 )
for ( i in 1:length(mark$bottom)){
temp[3 * i - 2] <- mark$bottom[i]
temp[3 * i - 1] <- mark$bottom[i]
temp[3 * i] <-NA
}
y <- temp + mark$parent$limits$top()
} else {
temp <- vector( mode = "numeric", length = length(mark$top) * 3 )
for ( i in 1:length(mark$top)){
temp[3 * i - 2] <- mark$parent$limits$bottom() - mark$top[i]
temp[3 * i - 1] <- mark$parent$limits$bottom() - mark$top[i]
temp[3 * i] <-NA
}
y <- temp
}
qlineWidth(canvas) <- mark$width
qdrawLine(canvas, x, y, stroke= mark$stroke)
}
draw.vbar <- function(mark, canvas) {
if( is.null(mark$top) ) {
temp <- vector (mode = "numeric", length = max(length(mark$left), length (mark$right)) * 3)
for (i in 1:(length(temp) / 3)) {
temp[3 * i - 2] <- mark$parent$limits$top()
temp[3 * i - 1] <- mark$parent$limits$bottom()
temp[3 * i] <- NA
}
y <- temp
# y <- c(mark$parent$limits$top(), mark$parent$limits$bottom())
} else {
temp <- vector( mode = "numeric", length = length(mark$top) * 3 )
for ( i in 1:length(mark$top) ) {
temp[3 * i - 2] <- mark$bottom[i]
temp[3 * i - 1] <- mark$parent$limits$bottom() - mark$top[i]
temp[3 * i] <- NA
}
y<-temp
y<- y + mark$parent$limits$top()
}
if( !is.null(mark$left) ) {
temp <- vector( mode = "numeric", length = length(mark$left) * 3)
for (i in 1:length(mark$left)) {
temp[3 * i - 2] <- mark$left[i]
temp[3 * i - 1] <- mark$left[i]
temp[3 * i] <- NA
}
x <- temp
# x <- c( mark$left, mark$left)
x <- x + mark$parent$limits$left()
} else {
temp <- vector( mode = "numeric", length = length(mark$right) * 3)
for (i in 1:length(mark$right)) {
temp[3 * i - 2] <- mark$parent$limits$height() - mark$right[i]
temp[3 * i - 1] <- mark$parent$limits$height() - mark$right[i]
temp[3 * i] <- NA
}
x <- temp
# x <- c( mark$parent$limits$height() - mark$right, mark$parent$limits$height() - mark$right)
x <- x + mark$parent$limits$left()
}
qlineWidth(canvas) <- mark$width
qdrawLine( canvas, x, y, stroke = mark$stroke )
}
draw.text<-function(mark,canvas){
if( !is.null(mark$bottom) ) {
anchor_bottom <- mark$bottom
} else {
anchor_bottom <- mark$parent$limits$height() - mark$top
}
if ( !is.null(mark$left) ) {
anchor_left <- mark$left
} else {
anchor_left <- mark$parent$limits$width() - mark$right
}
anchor_left <- anchor_left + mark$parent$limits$left()
anchor_bottom <- anchor_bottom + mark$parent$limits$top()
qfont(canvas) <- qfont(family = mark$font, pointsize = mark$pointsize, italic = mark$italic)
qstrokeColor(canvas) <- mark$stroke
qdrawText(canvas, text = mark$text, x = anchor_left, y = anchor_bottom, valign = mark$valign, halign = mark$halign, rot=mark$rot)
}
update.cranvas <- function(object, ...) {
new <- list(...)
structure(defaults(new, object), class = class(object))
}
###End Draw Wrappers###
##########################################################
##########################################################
####Canvas & Layers###
#-------------
#Create a blank canvas
new_plot <- function(width = 600, height = 400, xrange = c(0, 1), yrange = c(0, 1)) {
size <- qsize(as.integer(c(width, height)))
limits <- qrect(xrange, yrange)
scene <- qscene()
root <- qlayer(scene)
root$setGeometry(qrect(0, 0, width, height))
# root$setMaximumHeight(height)
# root$setMaximumWidth(width)
self <- structure(list(scene=scene,root=root,limits=limits, size = size), class = "cranvas-plot")
self
}
#End blank canvas
#----------
#add layers to the canvas
add_layer<-function( parent,
mark,
keyPressFun = NULL,
keyReleaseFun = NULL,
mouseDoubleClickFun = NULL,
mouseMoveFun = NULL,
mousePressFun = NULL,
mouseReleaseFun = NULL,
wheelFun = NULL,
hoverMoveFun = NULL,
hoverEnterFun = NULL,
hoverLeaveFun = NULL,
contextMenuFun = NULL,
dragEnterFun = NULL,
dragLeaveFun = NULL,
dragMoveFun = NULL,
dropFun = NULL,
focusInFun = NULL,
focusOutFun = NULL,
sizeHintFun = NULL,
row=0L,col=0L,
userlimits=NULL,
geometry = qrect(0,0,600,400),
clip = F,
colspan = 1L,
rowspan = 1L ){
if(class(mark)[1]=="function"){
paintFun<-mark
}else{
paintFun<-function(item, painter, exposed) { draw(mark, painter)}
}
if(is.null(userlimits)){
limits<-parent$limits
}else {
limits<-userlimits
}
layer<- qlayer( parent=parent$root,
paintFun=paintFun,
keyPressFun=keyPressFun,
keyReleaseFun=keyReleaseFun,
mouseDoubleClickFun=mouseDoubleClickFun,
mouseMoveFun=mouseMoveFun,
mousePressFun=mousePressFun,
mouseReleaseFun=mouseReleaseFun,
wheelFun=wheelFun,
hoverMoveFun = hoverMoveFun,
hoverEnterFun = hoverEnterFun,
hoverLeaveFun = hoverLeaveFun,
contextMenuFun = contextMenuFun,
dragEnterFun = dragEnterFun,
dragLeaveFun = dragLeaveFun,
dragMoveFun = dragMoveFun,
dropFun = dropFun,
focusInFun = focusInFun,
focusOutFun = focusOutFun,
sizeHintFun = sizeHintFun,
clip = clip,
limits = limits,
row = row,
col = col,
geometry = geometry,
rowSpan = rowspan,
colSpan = colspan)
layer$setLimits(limits)
self<- structure(list(layer=layer, limits = limits))
self
}
#End add_layer
#--------------------------------
#modify a layer
modify_layer<-function( layerID,
parent,
show=NULL, #true or false
enabled=NULL, #true (allows interaction) or false (no interaction, faded appearance)
alpha=NULL, #ranges from 0.0(transparent) to 1.0 (opaque)
shift_right=NULL, #in canvas coordinates, see width above
shift_down=NULL #in canvas coordinates, see height above
){
if(!is.null(show) && show==TRUE){
parent$root$childItems()[[layerID]]$show()
}else if (!is.null(show) && show==F){
parent$root$childItems()[[layerID]]$hide()
}
if(!is.null(enabled)){
parent$root$childItems()[[layerID]]$setEnabled(enabled)
}
if(!is.null(alpha)){
parent$root$childItems()[[layerID]]$setOpacity(alpha)
}
if(!is.null(shift_right)){
parent$root$childItems()[[layerID]]$setX(shift_right)
}
if(!is.null(shift_down)){
parent$root$childItems()[[layerID]]$setY(shift_down)
}
}
# End modify_layer
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.