Skip to content
Find file
Fetching contributors…
Cannot retrieve contributors at this time
943 lines (872 sloc) 38.1 KB
##' Draw a time plot
##'
##' Draw a time-series plot.
##'
##' Arrow up/down: in-/de-crease size of points.
##' Arrow left/right: wrap the time series when wrap=TRUE, while zoom
##' in/out with the center of the last clicked dot when wrap=FALSE.
##' Shift + right: when wrap=TRUE, the time series will be folded
##' directly to the width of maximal value in argument shift.
##' Shift + left: time series will be backed to the original xaxis
##' position, no matter wrap is TRUE or FALSE.
##' Key '+'/'-': de-/in-crease alpha level (starts at alpha=1 by
##' default).
##' Key 'u'/'d': separate/mix the series groups by shifting them up
##' and down.
##' Shift + 'u'/'d': for multivariate y's, separate/mix them by shifting
##' up and down.
##' Key 'g': change the wrapping period circularly in the values of
##' parameter 'shift'.
##' Key 'm': Switch the mode for series selecting. Default to be off.
##' When there are more than one series in the plot, users can turn it
##' on to hold a series and shift the series horizontally by dragging
##' with the mouse.
##' Wheel: Zoom in/out. Then users can drag the series horizontally
##' to see the details.
##' @param time The variable indicating time, which is displayed on
##' the horizontal axis
##' @param data Mutaframe data generated by \code{\link{time_qdata}}.
##' @param period The variable to group the time series. Better to be
##' 'year','month', or other time resolutions. Default to be
##' null. When it is not null, the key U and D can be hit to separate
##' the groups or overlap them together to watch the patterns.
##' @param group Similar to period, but is used for longitudinal data grouping.
##' @param shift Wrapping speed selector. The default possible speeds
##' are 1,7(for days a week),12(for months),24(for hours).
##' @param size Point size, default to be 2.
##' @param alpha Transparency level, 1=completely opaque, default to be 1.
##' @param asp Ratio between width and height of the plot.
##' @param similarity.index Whether to show the statistics which measure the similarity between series when wrapping. It gives the ACF, corr, and R square for one, two, and more series respectively.
##' @param help.text Whether to show the instruction. All the text will disappear in 2 seconds after the interaction.
##' @param main main title for the plot.
##' @param xlab label on horizontal axis, default is name of x variable
##' @param ylab label on vertical axis, default is name of y variable
##' @example inst/examples/qtime-ex.R
##' @export
##' @family plots
qtime <- function(time, data, period=NULL, group=NULL,
shift=c(1,4,7,12,24), size=3, alpha=1, asp=NULL,
similarity.index=is.null(period) && is.null(group),
help.text=TRUE, main=NULL, xlab=NULL, ylab=NULL,...){
#####################
## data processing ##----------
#####################
data <- check_data(data)
call <- as.list(match.call()[-1])
b <- brush(data)
meta <- Time.meta$new(varname = list(x = as.character(call$time)), minor = 'xy')
time_meta_initialize(meta,call,data=data,period=period, group=group, wrap=wrap,
shift=shift, size=size, alpha=alpha, asp=asp,
main=main, xlab=xlab, ylab=ylab)
meta$active <- TRUE
tree <- createTree(data.frame(x=meta$xtmp,y=meta$ytmp))
####################
## event handlers ##----------
####################
brush_mouse_press <- function(layer, event) {
meta$start <- as.numeric(event$pos())
if (event$button() == Qt$Qt$RightButton) {
meta$brush.move <- FALSE
b$cursor <- 2L
}
if (event$button() == Qt$Qt$LeftButton) {
meta$brush.move <- TRUE
if (meta$serie.mode | meta$drag.mode) {
b$cursor <- 18L
if (meta$serie.mode) {
meta$serie.start <- TRUE
}
} else {
b$cursor <- 0L
}
}
}
brush_mouse_move <- function(layer, event) {
if (event$button() != Qt$Qt$NoButton) {
b$cursor <- 0L
}
meta$pos <- as.numeric(event$pos())
if (meta$serie.start | meta$drag.mode) {
if (meta$serie.start) {
hits <- selected(data)[meta$orderEnter]
meta$xtmp[hits] <- meta$xtmp[hits] + meta$pos[1] - meta$start[1]
} else {
meta$limits[1:2] <- meta$limits[1:2] - meta$pos[1] + meta$start[1]
if (meta$limits[1,1]<extend_ranges(meta$time)[1]) {
meta$limits[1:2] <- meta$limits[1:2] - meta$limits[1,1] + extend_ranges(meta$time)[1]
} else if (meta$limits[2,1]>extend_ranges(meta$time)[2]) {
meta$limits[1:2] <- meta$limits[1:2] - meta$limits[2,1] + extend_ranges(meta$time)[2]
}
meta$xat <- axis_loc(meta$limits[1:2])
meta$xlabels <- format(meta$xat)
}
qupdate(main_circle_layer)
qupdate(main_line_layer)
return()
}
rect <- as.matrix(qrect(update_brush_size(meta)))
hits <- rectLookup(tree, rect[1, ], rect[2, ])
if (length(hits)<1) {
selected(data) <- FALSE
return()
}
selected(data) <- meta$orderEnter[hits]
}
brush_mouse_release <- function(layer, event){
brush_mouse_move(layer, event)
meta$serie.start <- FALSE
}
mouse_wheel <- function(layer, event) {
pos <- as.numeric(event$pos())
lim <- meta$limits
p <- (pos - lim[1, ]) / (lim[2, ] - lim[1, ])
meta$limits[1:2] <- extend_ranges(meta$limits[1:2], -sign(event$delta()) * 0.05 * c(p[1], 1 - p[1]))
meta$helptext <- paste("Wheel: Zoom",ifelse(sign(event$delta())>0,"in","out"))
tmprange <- extend_ranges(unlist(meta$xtmp))
meta$limits[1,1] <- max(meta$limits[1,1],min(tmprange))
meta$limits[2,1] <- min(meta$limits[2,1],max(tmprange))
meta$drag.mode <- ifelse(meta$limits[1,1]<=min(tmprange) & meta$limits[2,1]>=max(tmprange), FALSE, TRUE)
timer$start()
}
query_hover <- function(item, event, ...) {
meta$query.pos <- as.numeric(event$pos())
# if (meta$serie.mode) meta$serie.pos <- as.numeric(event$pos())
qupdate(query_layer)
}
query_hover_leave <- function(item, event, ...) {
meta$query.pos <- NULL
# if (meta$serie.mode) meta$serie.pos <- NULL
qupdate(query_layer)
}
key_press <- function(layer, event){
crt_range <- diff(range(meta$xtmp,na.rm=TRUE))+1
keys <- c('M','G','U','D','Left','Right','Up','Down','Plus','Minus')
meta$shift <- shift_on(event)
key <- keys[match_key(keys,event)]
if (!length(key)) return()
meta$helptext <- paste("Key:",ifelse(meta$shift,"Shift +",""),key)
switch(key,
M = switch_serie_mode(meta, data),
G = shift_wrap_gear(meta),
U = separate_group(meta),
D = mix_group(meta),
Left = wrap_backward(meta,data,crt_range),
Right = wrap_forward(meta,data,crt_range),
Up = size_up(meta),
Down = size_down(meta),
Plus = alpha_plus(meta),
Minus = alpha_minus(meta)
)
tree <<- createTree(data.frame(x=meta$xtmp,y=meta$ytmp))
qupdate(main_circle_layer)
qupdate(main_line_layer)
timer$start()
}
############
## layers ##----------
############
main_circle_draw <- function(layer,painter){
maxgroup = max(meta$wrap.group)
color = alpha(data$.color, seq(0,1,length=maxgroup+1)[meta$wrap.group+1])
qdrawGlyph(painter, qglyphCircle(r = meta$radius), meta$xtmp, meta$ytmp,
fill=alpha(color,meta$alpha), stroke=alpha(color,meta$alpha))
}
main_line_draw <- function(layer,painter){
qlineWidth(painter) <- meta$radius / 2
maxgroup = max(meta$wrap.group)
color=gray(seq(0,0.6,length=max(meta$wrap.group,na.rm=TRUE)))
for (j in 1:meta$nyvar) {
for (k in unique(meta$vargroup)) {
for (i in 1:maxgroup) {
if (sum(meta$wrap.group==i & meta$vargroup==k)){
tmprow <- 1:meta$singleVarLen + meta$singleVarLen * (j-1)
qdrawLine(painter,
meta$xtmp[meta$wrap.group==i & meta$vargroup==k & 1:length(meta$xtmp) %in% tmprow],
meta$ytmp[meta$wrap.group==i & meta$vargroup==k & 1:length(meta$ytmp) %in% tmprow],
stroke=alpha(color[maxgroup+1-i],meta$alpha))
}
}
}
}
}
brush_draw <- function(layer, painter) {
if (any(is.na(meta$pos))) return()
if (meta$drag.mode) {
qupdate(main_circle_layer)
qupdate(main_line_layer)
return()
}
hits <- selected(data)[meta$orderEnter]
if (meta$serie.mode) {
if (!any(hits)) return()
#meta$xtmp[hits] <- meta$xtmp[hits] + meta$pos[1] - meta$start[1]
selected_draw(meta,b,hits,painter)
return()
}
if (any(hits)) selected_draw(meta,b,hits,painter)
draw_brush(layer, painter, data, meta)
}
query_draw <- function(item, painter, exposed, ...) {
if (is.null(meta$query.pos)) return()
xpos <- meta$query.pos[1]
ypos <- meta$query.pos[2]
if (!meta$serie.mode){
queryaround <- ifelse(meta$radius<=4,8/meta$radius,1)
xrange <- meta$radius/layer.root$size$width() * diff(meta$limits[c(1, 2)]) * queryaround
yrange <- meta$radius/layer.root$size$height() * diff(meta$limits[c(3, 4)]) * queryaround
rect <- matrix(c(xpos - xrange, ypos - yrange, xpos + xrange, ypos + yrange),
2, byrow = TRUE)
hits <- rectLookup(tree, rect[1, ], rect[2, ])
## Nothing under mouse?
if (length(hits) < 1) return()
if (length(hits) > 1) {
hitsdist <- rep(0,length(hits))
for (i in 1:length(hits)){
hitsdist[i] <- sqrt((xpos-meta$xtmp[hits[i]])^2 + (ypos-meta$ytmp[hits[i]])^2)
}
distidx <- which(hitsdist==min(hitsdist,na.rm=TRUE))
hits <- hits[distidx]
}
if (length(meta$group)==0) {
info <- data.frame(meta$varname$x,meta$time[hits],
meta$yorig[hits,1],meta$yorig[hits,2])
} else {
info <- data.frame(meta$varname$x, meta$time[hits],
meta$yorig[hits,1],meta$yorig[hits,2],
meta$varname$g,meta$group[hits])
}
## label position
labelxpos <- mean(meta$xtmp[hits])
labelypos <- mean(meta$ytmp[hits])
## label text
idx <- (1:(ncol(info)/2))*2
if (length(hits) == 1) {
infoname <- as.character(unlist(info[1,idx-1]))
infodata <- as.character(unlist(info[1,idx]))
infostring <- paste(infoname, infodata, collapse = "\n", sep = ": ")
} else {
xymin <- unlist(lapply(info[, idx], min, na.rm = TRUE))
xymax <- unlist(lapply(info[, idx], max, na.rm = TRUE))
if (max(table(info[,3]))==1){
infostring <- paste(as.character(unlist(info[1,idx-1])), paste(xymin, xymax, sep = " - "),
collapse = "\n", sep = ": ")
infostring <- paste(length(hits),"points\n", infostring)
} else {
infoname <- c(as.character(unlist(info[1,idx-1])[-2]),unique(info[,3]))
xymin <- c(xymin[-2],tapply(info[,4],info[,3],min))
xymax <- c(xymax[-2],tapply(info[,4],info[,3],max))
infodata <- paste(xymin, xymax, sep = " - ")
infostring <- paste(infoname, infodata, collapse = "\n", sep = ": ")
}
}
bgwidth <- qstrWidth(painter, infostring)
bgheight <- qstrHeight(painter, infostring)
## adjust drawing directions when close to the boundary
hflag <- meta$limits[2] - xpos > bgwidth
vflag <- ypos - meta$limits[3] > bgheight
qdrawRect(painter, labelxpos, labelypos,
labelxpos + ifelse(hflag, 1, -1) * bgwidth,
labelypos + ifelse(vflag, -1, 1) * bgheight,
stroke = rgb(1, 1, 1),
fill = rgb(1, 1, 1, 0.9))
qstrokeColor(painter) <- b$label.color
qdrawText(painter, infostring, labelxpos, labelypos,
halign = ifelse(hflag, "left", "right"),
valign = ifelse(vflag, "top", "bottom"))
} else {
if (length(meta$group)==0 & meta$nyvar==1) return()
xrange <- diff(meta$limits[c(1, 2)])/10
yrange <- diff(meta$limits[c(3, 4)])/10
rect <- matrix(c(xpos - xrange, ypos - yrange, xpos + xrange, ypos + yrange),
2, byrow = TRUE)
hits <- rectLookup(tree, rect[1, ], rect[2, ])
if (length(hits) < 1) return()
if (length(hits) > 1) {
hitsdist <- rep(0,length(hits))
for (i in 1:length(hits)){
hitsdist[i] <- sqrt((xpos-meta$xtmp[hits[i]])^2 + (ypos-meta$ytmp[hits[i]])^2)
}
distidx <- which.min(hitsdist)
hits <- hits[distidx]
}
if (length(meta$group)) {
checkhitgroup <- meta$group==meta$group[hits]
} else {
checkhitgroup <- rep(TRUE, length(meta$ytmp))
}
hitsall <- which(meta$yorig[,1]==meta$yorig[hits,1] & checkhitgroup)
selected(data) <- hitsall[meta$orderBack]
hits <- selected(data)[meta$orderEnter]
selected_draw(meta,b,hits,painter)
}
}
similarity_draw <- function(layer, painter){
j <- is.null(call$period) & is.null(call$group)
if (!j) return()
tmp <- unique(meta$wrap.group)
if (length(tmp)==1){
ytmpacf <- unname(tapply(meta$ytmp,meta$yorig[,1],function(z) acf(z,lag.max=max(30,max(meta$wrap.shift)),plot=F)$acf[meta$wrap.shift[1]+1]))
tmpprint <- paste(meta$varname$y,": ACF(lag=",meta$wrap.shift[1],"):",round(ytmpacf,2),sep="")
} else if (length(tmp)==2) {
tmpdat=data.frame(ytmp=meta$ytmp,series=meta$wrap.group,label=meta$yorig[,1])
ytmpcor <- ddply(tmpdat,'label',summarise,res=cor(ytmp[series==1][1:sum(series==2)],ytmp[series==2]))[,2]
tmpprint <- paste(meta$varname$y,"Corr. of two series = ",round(ytmpcor,2),sep="")
} else {
tmpdat=data.frame(ytmp=meta$ytmp,xtmp=factor(meta$xtmp),label=meta$yorig[,1])
ytmpR2 <- ddply(tmpdat,'label',summarise,res=summary(lm(ytmp~xtmp))$r.squared)[,2]
tmpprint <- paste("R square = ",round(ytmpR2,2),sep="")
}
if (meta$shiftUP) {
qdrawText(painter,tmpprint,
rep(meta$limits[1,1],meta$nyvar),meta$yat-0.5,
halign='left',valign='bottom',color='gray50')
} else {
qdrawText(painter,paste(tmpprint,collapse="\n"),
meta$limits[1,1],meta$limits[1,2],
halign='left',valign='bottom',color='gray50')
}
}
helptext_draw <- function(layer,painter){
if (meta$helptext == "") return()
qdrawText(painter,meta$helptext,
meta$limits[2,1],meta$limits[1,2],
halign='right',valign='bottom',color='gray70', cex=2)
}
timer <- qtimer(2000, function() {
meta$helptext <- ""
qupdate(helptext_layer)
})
#####################
## draw the canvas ##----------
#####################
asp_ratio <- function(x,y){
if (length(x)!=length(y)) return(0.5)
x <- (x-min(x,na.rm=TRUE))/(max(x,na.rm=TRUE)-min(x,na.rm=TRUE))
y <- (y-min(y,na.rm=TRUE))/(max(y,na.rm=TRUE)-min(y,na.rm=TRUE))
r <- diff(y)/diff(x)
f <- function(a,r){
mean(abs(atan(a*r)))-pi/3
}
a=try(uniroot(f,c(0.1,1),r)$root, silent = TRUE)
if (class(a) == 'try-error') a <- 0.5
return(a)
}
if (is.null(asp)) {
a <- asp_ratio(meta$time,meta$y)
if (a<0.35) {
xWidth <- 1280
yWidth <- max(round(xWidth*a),320)
} else {
yWidth <- 750
xWidth <- round(yWidth/a)
}
} else {
yWidth <- 600
xWidth <- round(yWidth*asp)
}
scene <- qscene()
layer.root <- qlayer(scene)
layer.title <- qmtext(meta = meta, side = 3)
layer.xlab = qmtext(meta = meta, side = 1)
layer.ylab = qmtext(meta = meta, side = 2)
layer.xaxis = qaxis(meta = meta, side = 1)
layer.yaxis = qaxis(meta = meta, side = 2)
layer.grid = qgrid(meta = meta)
main_circle_layer <- qlayer(paintFun = main_circle_draw,
limits = qrect(meta$limits),
hoverMoveFun = query_hover,
hoverLeaveFun = query_hover_leave,
mousePressFun = brush_mouse_press,
mouseReleaseFun = brush_mouse_release,
mouseMove = brush_mouse_move,
wheelFun = mouse_wheel,
keyPressFun = key_press,
focusInFun = function(layer, event) {
common_focus_in(layer, event, data, meta)
}, focusOutFun = function(layer, event) {
common_focus_out(layer, event, data, meta)
}, clip=TRUE)
main_line_layer <- qlayer(paintFun=main_line_draw,limits=qrect(meta$limits),clip=TRUE)
brush_layer <- qlayer(paintFun=brush_draw, limits=qrect(meta$limits))
query_layer <- qlayer(paintFun=query_draw, limits=qrect(meta$limits))
if (similarity.index) similarity_layer <- qlayer(paintFun=similarity_draw, limits=qrect(meta$limits))
if (help.text) helptext_layer <- qlayer(paintFun=helptext_draw, limits=qrect(meta$limits))
layer.root[0, 2] = layer.title
if (help.text) layer.root[0, 2] = helptext_layer
layer.root[2, 2] = layer.xaxis
layer.root[3, 2] = layer.xlab
layer.root[1, 1] = layer.yaxis
layer.root[1, 0] = layer.ylab
layer.root[1, 2] = layer.grid
if (similarity.index) layer.root[1, 2] = similarity_layer
layer.root[1, 2] = main_circle_layer
layer.root[1, 2] = main_line_layer
layer.root[1, 2] = brush_layer
layer.root[1, 2] = query_layer
layer.root[1, 3] = qlayer()
## set sizes of layers (arrange the layout)
set_layout = function() {
fix_dimension(layer.root,
row = list(id = c(0, 2, 3), value = c(prefer_height(meta$main),
prefer_height(meta$xlabels),
prefer_height(meta$xlab))),
column = list(id = c(1, 0, 3), value = c(prefer_width(meta$ylabels),
prefer_width(meta$ylab, FALSE),
10)))
}
set_layout()
## layout is dynamic (listen to changes in xlab/ylab/xlabels/ylabels...)
meta$mainChanged$connect(set_layout)
meta$xlabChanged$connect(set_layout); meta$ylabChanged$connect(set_layout)
meta$xlabelsChanged$connect(set_layout); meta$ylabelsChanged$connect(set_layout)
## listeners on the data (which column updates which layer(s))
d.idx = add_listener(data, function(i, j) {
switch(j, .brushed = qupdate(brush_layer),
.color = {
qupdate(main_circle_layer)
qupdate(main_line_layer)
}, {
qupdate(layer.grid); qupdate(layer.xaxis); qupdate(layer.yaxis)
main_circle_layer$invalidateIndex()
main_line_layer$invalidateIndex()
qupdate(main_circle_layer)
qupdate(main_line_layer)
})
})
qconnect(main_circle_layer, 'destroyed', function(x) {
## b$colorChanged$disconnect(b.idx)
remove_listener(data, d.idx)
})
b$cursorChanged$connect(function() {
set_cursor(view, b$cursor)
})
sync_limits(meta, main_circle_layer,main_line_layer,
query_layer, brush_layer,
if (similarity.index){similarity_layer} else {NA},
if (help.text) {helptext_layer} else {NA})
meta$manual.brush = function(pos) {
brush_mouse_move(layer = main_circle_layer, event = list(pos = function() pos))
}
view <- qplotView(scene=scene)
view$setWindowTitle(meta$main)
view$resize(xWidth,yWidth)
attr(view, 'meta') = meta
view
}
Time.meta =
setRefClass("Time_meta", fields =
properties(c(Common.meta,
list(varname = 'list',
time = 'numeric',
y = 'numeric',
yorig = 'data.frame',
group = 'factor',
orderEnter = 'numeric',
orderBack = 'numeric',
xtmp = 'numeric',
ytmp = 'numeric',
shadow.matrix = 'data.frame',
drag.mode = 'logical',
serie.mode = 'logical',
shift = 'logical',
query.pos = 'numeric',
wrap.group = 'numeric',
wrap.shift = 'numeric',
vargroup = 'factor',
zoomsize = 'numeric',
limits = 'matrix',
radius = 'numeric',
stroke = 'character',
fill = 'character',
helptext = 'character'))))
##' Create data for drawing time plots
##'
##' @param data a data frame for time plot
##' @param y a vertor of all the variable names of interest
##' @inheritParams qdata
##' @return A mutaframe of multiple y's
##' @export
##' @examples
##' library(cranvas); data(nasa)
##' nasa11 <- subset(nasa, Gridx == 22 & Gridy == 21)
##' qnasa <- time_qdata(nasa11,c("ts","ps_tovs","ca_med"))
##'
time_qdata <- function(regular_qdata, y) {
ycol <- length(y)
data <- as.data.frame(regular_qdata)
usecol <- colnames(data) %in% c(".brushed",".visible",".color",".border",".size")
setting <- settingh <- data[, usecol]
data <- data[, !usecol]
data$.row <- 1:nrow(data)
newdat <- data.frame(.variable=rep(y[1],nrow(data)),.value=data[,y[1]],data)
newdat[,y[1]] <- TRUE
newdat[,y[-1]] <- FALSE
if (ycol > 1) {
for (i in 2:ycol) {
tmpnewdat <- data.frame(.variable=rep(y[i],nrow(data)),.value=data[,y[i]],data)
tmpnewdat[,y[i]] <- TRUE
tmpnewdat[,y[-i]] <- FALSE
newdat <- rbind(newdat, tmpnewdat)
settingh <- rbind(settingh, setting)
}
}
newdat$.variable <- as.factor(newdat$.variable)
newdat <- qdata(newdat,color = as.character(settingh[,3]),
border = as.character(settingh[,4]),
size = settingh[,5], brushed = settingh[,1],
visible = settingh[,2])
change_back = change_forward = FALSE
add_listener(newdat,function(i,j){
if (j != ".brushed" || change_back) return()
change_back <<- TRUE
change_forward <<- TRUE
tmp <- sort(unique(which(newdat$.brushed) %% nrow(regular_qdata)),decreasing=FALSE)
if (0 %in% tmp) {tmp=c(tmp[-1],nrow(regular_qdata))}
if (!length(tmp)) tmp <- FALSE
tmpbrush <- rep(FALSE,nrow(regular_qdata))
tmpbrush[tmp] <- TRUE
regular_qdata$.brushed <- tmpbrush
change_back <<- FALSE
change_forward <<- FALSE
})
add_listener(regular_qdata,function(i,j){
if (j != ".brushed" || change_forward) return()
change_forward <<- TRUE
change_back <<- TRUE
tmp <- which(regular_qdata$.brushed)+(0:(ycol-1))*nrow(regular_qdata)
if (!length(tmp)) tmp <- FALSE
tmpbrush <- rep(FALSE,nrow(newdat))
tmpbrush[tmp] <- TRUE
newdat$.brushed <- tmpbrush
change_back <<- FALSE
change_forward <<- FALSE
})
return(newdat)
}
##' Initialize the Time.meta
time_meta_initialize <- function(meta,call,data,period, group,
shift, size, alpha, asp,
main, xlab, ylab,...){
## X axis setting
meta$time <- eval(call$time, as.data.frame(data))
meta$xtmp <- meta$time
meta$xlab <- ifelse(is.null(xlab), meta$varname$x, xlab)
meta$singleVarLen <- max(data$.row)
meta$nyvar <- length(table(data$.variable))
## Period for time series / Group for panel data
if (is.null(call$period) & is.null(call$group)) {
meta$vargroup <- factor(rep(1, nrow(data)))
meta$orderEnter <- order(meta$time[1:meta$singleVarLen], decreasing=FALSE)
meta$orderEnter <- rep(meta$orderEnter,meta$nyvar)+
rep((0:(meta$nyvar-1))*meta$singleVarLen,each=meta$singleVarLen)
meta$orderBack <- rank(meta$time[1:meta$singleVarLen],ties.method='first')
meta$orderBack <- rep(meta$orderBack,meta$nyvar)+
rep((0:(meta$nyvar-1))*meta$singleVarLen,each=meta$singleVarLen)
} else {
if (!is.null(call$period)) {
meta$varname$g <- as.character(call$period)
} else {
meta$varname$g <- as.character(call$group)
}
meta$orderEnter <- order(as.factor(data[1:meta$singleVarLen,meta$varname$g]),
meta$time[1:meta$singleVarLen], decreasing=FALSE)
meta$orderEnter <- rep(meta$orderEnter,meta$nyvar)+
rep((0:(meta$nyvar-1))*meta$singleVarLen,each=meta$singleVarLen)
meta$orderBack <- rank(meta$time[1:meta$singleVarLen] +
as.integer(as.factor(data[1:meta$singleVarLen,meta$varname$g])) *
(max(meta$time[1:meta$singleVarLen],na.rm=TRUE)+1),
ties.method='first')
meta$orderBack <- rep(meta$orderBack,meta$nyvar)+
rep((0:(meta$nyvar-1))*meta$singleVarLen,each=meta$singleVarLen)
meta$group <- factor(data[meta$orderEnter,meta$varname$g])
meta$vargroup <- meta$group
}
if (!all(meta$orderEnter==1:nrow(data))) {
meta$time <- meta$time[meta$orderEnter]
meta$xtmp <- meta$xtmp[meta$orderEnter]
}
if (!is.null(call$period)) {
pdLen <- tapply(meta$time,factor(paste(as.character(data$.variable), as.character(meta$group),sep="")),length)
if (!all(pdLen==pdLen[1])) {
warning('Period lengths are not the same.')
## need to be modified here !!
maxpdLen <- max(pdLen)
meta$time <- meta$time %% maxpdLen
meta$time[meta$time==0] <- maxpdLen
} else {
meta$time <- rep(1:pdLen[1],length=length(meta$time))
}
meta$xtmp <- meta$time
}
## Y axis setting
meta$varname$y <- as.character(unique(data$.variable))
meta$yorig <- as.data.frame(data)[meta$orderEnter,c(".variable",".value")]
meta$ylist <- as.data.frame(as.data.frame(data)[meta$orderEnter,meta$varname$y])
meta$y <- meta$yorig[,2]
if (meta$nyvar>1) {
for (i in 1:meta$nyvar) {
tmprow <- meta$ylist[,i]
tmprowdat <- meta$yorig[tmprow,2]
meta$y[tmprow] <- (tmprowdat - min(tmprowdat, na.rm = TRUE))/
diff(range(tmprowdat, na.rm = TRUE))
}
}
meta$ytmp <- meta$y
meta$ylab <- ifelse(is.null(ylab), paste(meta$varname$y,collapse=', '), ylab)
## Other settings
meta$drag.mode <- FALSE
meta$shift <- FALSE
meta$wrap.group <- rep(1, nrow(data))
meta$wrap.shift <- shift
meta$hitscol <- 1
meta$hitsrow <- NULL
meta$vertconst <- 0
meta$linkID <- NULL
meta$helptext <- ""
## Range, axes, etc.
meta$zoomsize <- diff(range(meta$xtmp, na.rm = TRUE))
meta$limits <- matrix(c(extend_ranges(meta$xtmp),
extend_ranges(range(meta$ytmp, na.rm = TRUE))), nrow=2)
meta$xat <- axis_loc(meta$limits[1:2])
meta$yat <- axis_loc(meta$limits[3:4])
meta$xlabels <- format(meta$xat)
meta$ylabels <- format(meta$yat)
meta$shiftUP <- FALSE
meta$shiftDOWN <- FALSE
## Radius, color, etc.
meta$radius <- size
meta$alpha <- alpha
meta$stroke <- data$.border[meta$orderEnter]
meta$fill <- data$.color[meta$orderEnter]
meta$serie.mode <- FALSE
## Brush etc.
meta$pos <- c(NA, NA)
meta$query.pos <- NULL
meta$start <- c(NA, NA)
meta$serie.start <- FALSE
meta$brush.move <- TRUE
meta$brush.size <- c(diff(meta$limits[1:2]),
-diff(meta$limits[3:4]))/30
## Title
meta$main <- if (is.null(main))
sprintf("Time Plot of %s And %s",
meta$varname$x, paste(meta$varname$y, collapse=', ')) else main
}
##' Set limits for yaxis in qtime
meta.yaxis <- function(meta) {
if (meta$shiftUP) {
meta$yat <- 1:meta$nyvar+0.5
meta$ylabels <- meta$varname$y
meta$ylab <- ""
#meta$shiftUP <- FALSE
} else if (meta$shiftDOWN) {
meta$yat <- axis_loc(meta$limits[3:4])
meta$ylabels <- format(meta$yat)
meta$ylab <- paste(meta$varname$y,collapse=', ')
meta$shiftUP <- FALSE
} else {
if (is.null(meta$group) | !meta$vertconst){
meta$yat <- axis_loc(meta$limits[3:4])
} else {
meta$yat <- (as.integer(unique(meta$group))-0.5)*meta$vertconst
}
if (meta$vertconst==0) {
meta$ylabels <- format(meta$yat)
meta$ylab <- ifelse(is.null(ylab), paste(meta$varname$y,collapse=', '), ylab)
} else {
meta$ylabels <- format(unique(meta$group))
meta$ylab <- meta$varname$g
}
}
}
##' Draw the selected data in qtime
selected_draw <- function(meta,b,hits,painter){
qdrawGlyph(painter, qglyphCircle(r = meta$radius*2), meta$xtmp[hits],
meta$ytmp[hits], stroke = b$color, fill = b$color)
qlineWidth(painter) <- max(meta$radius,1)
for (i in 1:meta$nyvar){
for (k in unique(meta$vargroup)) {
for (j in 1:max(meta$wrap.group,na.rm=TRUE)) {
idxtmp <- (meta$wrap.group==j & meta$vargroup==k & meta$ylist[,i] & hits)
if (sum(idxtmp)){
xtmp <- meta$xtmp
ytmp <- meta$ytmp
xtmp[!idxtmp] <- NA
ytmp[!idxtmp] <- NA
qdrawLine(painter, xtmp, ytmp, stroke=b$color)
}
}
}
}
}
##' key M for switching the serie mode
##' on the serie mode users can drag any serie horizontally
switch_serie_mode = function(meta,data){
if (meta$drag.mode) {
meta$drag.mode <- FALSE
meta$serie.mode <- FALSE
return()
}
if (length(meta$group)){
meta$serie.mode <- !meta$serie.mode
if (!meta$serie.mode) {
remove_listener(data,meta$linkID)
meta$linkID <- NULL
} else {
if (class(data[,meta$varname$g])=='factor'){
meta$linkID <- link_cat(data, meta$varname$g)
} else {
message("The group variable is not a factor. Please change to factor before pressing M.")
meta$serie.mode <- FALSE
}
}
} else if (meta$nyvar>1) {
meta$serie.mode <- !meta$serie.mode
}
}
##' key G for shifting the wrapping gear
##' i.e. changing the period/frequency
shift_wrap_gear = function(meta){
meta$wrap.shift <- c(meta$wrap.shift[-1],meta$wrap.shift[1])
#qupdate(layer.WRAPtext)
}
##' key U for separating the groups by shifting up
separate_group <- function(meta){
if (meta$nyvar>1 & meta$shift) {
for (i in 1:meta$nyvar){
meta$ytmp[meta$ylist[,i]] <- meta$y[meta$ylist[,i]]+i
}
meta$shiftUP <- TRUE
} else if (!is.null(meta$group) & length(meta$group)>0) {
meta$vertconst <- meta$vertconst + 0.05
if (meta$vertconst>1) meta$vertconst <- 1
for (j in 1:meta$nyvar) {
meta$ytmp[meta$ylist[,j]] <- (meta$y[meta$ylist[,j]]-min(meta$y,na.rm=TRUE))/
diff(range(meta$y,na.rm=TRUE))+(as.integer(meta$group)-1)*meta$vertconst
}
}
meta$limits[3:4] <- extend_ranges(range(meta$ytmp,na.rm=TRUE))
meta.yaxis(meta)
}
##' key D for mixing the groups
mix_group <- function(meta){
meta$shiftUP <- FALSE
if (meta$nyvar>1 & meta$shift) {
meta$ytmp <- meta$y
meta$shiftDOWN <- TRUE
} else {
if (!is.null(meta$group) & length(meta$group)>0) {
meta$vertconst <- meta$vertconst - 0.05
if (meta$vertconst<0) meta$vertconst <- 0
if (!meta$vertconst) {
meta$ytmp <- meta$y
meta$limits[3:4] <- extend_ranges(range(meta$ytmp,na.rm=TRUE))
} else {
for (j in 1:meta$nyvar) {
meta$ytmp[meta$ylist[,j]] <- (meta$y[meta$ylist[,j]]-min(meta$y,na.rm=TRUE))/
diff(range(meta$y,na.rm=TRUE))+(as.integer(meta$group)-1)*meta$vertconst
}
}
}
}
meta$limits[3:4] <- extend_ranges(range(meta$ytmp,na.rm=TRUE))
meta.yaxis(meta)
}
##' key Right for wrapping
wrap_forward <- function(meta,data,crt_range){
hits <- selected(data)[meta$orderEnter]
if (meta$serie.mode & sum(hits)) {
if (min(meta$xtmp[hits],na.rm=TRUE)<=max(meta$time,na.rm=TRUE)){
meta$xtmp[hits] <- meta$xtmp[hits] + diff(range(meta$time,na.rm=TRUE))/meta$singleVarLen
}
} else if (!length(meta$group) & meta$shift) {
zoombound <- max(meta$wrap.shift)
if (zoombound<2) zoombound <- diff(range(meta$time,na.rm=TRUE))/4
meta$xtmp <- meta$time %% zoombound
meta$wrap.group <- ceiling(meta$time/zoombound)
if (sum(meta$xtmp==0)){
meta$wrap.group[meta$xtmp==0] <- meta$wrap.group[which(meta$xtmp==0)-1]
meta$xtmp[meta$xtmp==0] <- zoombound
}
meta$limits[1:2] <- extend_ranges(meta$xtmp)
} else if (!meta$serie.mode) {
zoombound <- crt_range-meta$wrap.shift[1]
if (meta$wrap.shift[1]==1 & zoombound<3){
zoombound <- 3
} else if (meta$wrap.shift[1]!=1 & zoombound<meta$wrap.shift[1]){
zoombound <- crt_range %% meta$wrap.shift[1]
if (!zoombound) zoombound <- meta$wrap.shift[1]
}
meta$xtmp <- meta$time %% zoombound
meta$wrap.group <- ceiling(meta$time/zoombound)
if (sum(meta$xtmp==0)){
meta$wrap.group[meta$xtmp==0] <- meta$wrap.group[which(meta$xtmp==0)-1]
meta$xtmp[meta$xtmp==0] <- zoombound
}
meta$limits[1:2] <- extend_ranges(meta$xtmp)
}
meta$xat <- axis_loc(meta$limits[1:2])
meta$xlabels <- format(meta$xat)
}
##' key Left for back wrapping
wrap_backward <- function(meta,data,crt_range){
if (meta$shift) {
meta$xtmp <- meta$time
meta$wrap.group <- 1
meta$zoomsize <- diff(range(meta$xtmp, na.rm = TRUE))
meta$limits[1:2] <- extend_ranges(meta$xtmp)
meta$drag.mode <- FALSE
} else {
hits <- selected(data)[meta$orderEnter]
if (meta$serie.mode & sum(hits)) {
if (max(meta$xtmp[hits],na.rm=TRUE) >= min(meta$time,na.rm=TRUE)) {
meta$xtmp[hits] <- meta$xtmp[hits] - diff(range(meta$time,na.rm=TRUE))/meta$singleVarLen
}
} else if (!meta$serie.mode) {
zoombound <- crt_range+meta$wrap.shift[1]
if (zoombound>(meta$zoomsize+min(meta$time,na.rm=TRUE))) {
zoombound <- meta$zoomsize+min(meta$time,na.rm=TRUE)
}
meta$xtmp <- meta$time %% zoombound
meta$wrap.group <- ceiling(meta$time/zoombound)
if (sum(meta$xtmp==0)){
meta$wrap.group[meta$xtmp==0] <- meta$wrap.group[which(meta$xtmp==0)-1]
meta$xtmp[meta$xtmp==0] <- zoombound
}
while (diff(range(meta$xtmp,na.rm=TRUE))+1 <= crt_range &
zoombound<meta$zoomsize+min(meta$time,na.rm=TRUE)) {
zoombound <- zoombound+max(meta$wrap.shift)
if (zoombound>(meta$zoomsize+min(meta$time,na.rm=TRUE))) {
zoombound <- meta$zoomsize+min(meta$time,na.rm=TRUE)
}
meta$xtmp <- meta$time %% zoombound
meta$wrap.group <- ceiling(meta$time/zoombound)
if (sum(meta$xtmp==0)){
meta$wrap.group[meta$xtmp==0] <- meta$wrap.group[which(meta$xtmp==0)-1]
meta$xtmp[meta$xtmp==0] <- zoombound
}
}
meta$limits[1:2] <- extend_ranges(meta$xtmp)
}
}
meta$xat <- axis_loc(meta$limits[1:2])
meta$xlabels <- format(meta$xat)
}
##' key Up/Down for adjusting the point size / line width
size_up <- function(meta){
meta$radius <- meta$radius + 1
}
size_down <- function(meta){
meta$radius <- max(0.1, meta$radius - 1)
}
##' key Plus/Minus for alpha blending
alpha_plus <- function(meta){
meta$alpha <- max(0.01, 1/nrow(data), min(1, 1.1 * meta$alpha))
}
alpha_minus <- function(meta){
meta$alpha <- max(0.01, 1/nrow(data), min(1, 0.9 * meta$alpha))
}
`%md%` = function(x, y) {
z = (col2rgb(x, TRUE) + col2rgb(y, TRUE))/255/2
rgb(z[1, ], z[2, ], z[3, ], z[4, ])
}
Something went wrong with that request. Please try again.