##' Draw an interactive time plot
##'
##' Draw an interactive time plot.
##'
##' Arrow up/down: in-/de-crease size of points.
##'
##' Arrow left/right: wrap the time series in the initial mode, and
##' drag the series in the series selection mode.
##'
##' Shift + right: 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.
##'
##' Key '+'/'-': de-/in-crease alpha level (starts at alpha=1 by
##' default).
##'
##' Key 'u'/'d': separate/mix the series groups or the period by shifting them up
##' and down.
##'
##' Shift + 'u'/'d': for multivariate y's, separate/mix them by shifting
##' up and down.
##'
##' Key 'h'/'v': horizontally or vertically faceting the series.
##'
##' Shift + 'h'/'v': horizontally or vertically mix the faceting panels.
##'
##' Key 'g': change the wrapping period circularly in the values of
##' parameter 'shift'.
##'
##' Key 'm': Switch the mode for series selection. 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.
##'
##' Key 'y': y-wrapping
##'
##' Shift + 'y': y-wrapping backward
##'
##' Key 'r': switch to the area plot
##'
##' Key 'f': fold the series to a horizon plot
##'
##' Wheel: Zoom in/out. Then users can drag the series horizontally
##' to see the details.
##'
##' @param time the variable indicating time on the horizontal axis.
##' @param y a vertor of all the variable names of interest.
##' @param data Mutaframe data generated by \code{\link{qdata}}.
##' @param vdiv a vector of variable names that will be used in faceting vertically.
##' @param hdiv a vector of variable names that will be used in faceting horizontally.
##' @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 series.stats 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 fun.base a function to compute the baseline of the area plot
##' @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
##' @param infolab the variable(s) shown when identifying the points.
##' Note that the x, y, and group information is already shown.
##' @return A time plot.
##' @author Xiaoyue Cheng
##' @example inst/examples/qtime-ex.R
##' @export
##' @family plots
qtime = function(time, y, data, vdiv=NULL,hdiv=NULL,
shift=c(1,4,7,12,24), alpha=1, size=2, asp=NULL,
series.stats=ifelse(nrow(data)<1000,TRUE,FALSE), fun.base=min,
main=NULL, xlab=NULL, ylab=NULL,infolab=NULL,...){
#####################
## data processing ##----------
#####################
data = check_data(data)
call = as.list(match.call()[-1])
time = as.character(call$time)
y = as.character(call$y)
if(y[1] == "c") y = y[-1]
vdiv = as.character(call$vdiv)
if(length(vdiv) && vdiv[1] == "c") vdiv = vdiv[-1]
hdiv = as.character(call$hdiv)
if(length(hdiv) && hdiv[1] == "c") hdiv = hdiv[-1]
#if(length(intersect(vdiv,hdiv))) hdiv = setdiff(hdiv, vdiv)
group = union(vdiv,hdiv)
tdata = time_qdata(data, y, c(time,group))
meta = Time.meta$new(varname = list(x = time, y = y), minor = 'xy')
meta$brush = brush(tdata)
time_meta_initialize(meta, call, data=tdata, hdiv=hdiv, vdiv=vdiv,
shift=shift, alpha=alpha, size=size, asp=asp,
main=main, xlab=xlab, ylab=ylab, infolab=infolab)
#if ('g' %in% names(meta$varname) & series.stats) series.stats = FALSE
meta$active = TRUE
tree = createTree(data.frame(x=meta$data$xtmp,y=meta$data$ytmp))
update_meta_group(meta)
update_meta_xwrap_color(meta,tdata)
compute_area(meta,tdata,fun.base)
####################
## event handlers ##----------
####################
mouse_press = function(layer, event) {
common_mouse_press(layer, event, tdata, meta)
if ((meta$mode$serie | meta$mode$zoom) & event$button() == Qt$Qt$LeftButton) {
meta$brush$cursor = 18L
meta$data$xstart = meta$data$xtmp
}
}
mouse_move = function(layer, event) {
if (event$button() != Qt$Qt$NoButton) {
meta$brush$cursor = 0L
}
meta$pos = as.numeric(event$pos())
if (meta$mode$serie) {
hits = selected(tdata)[meta$data$order]
meta$data$xtmp[hits] = meta$data$xstart[hits] + meta$pos[1] - meta$start[1]
qupdate(layer.brush)
return()
}
if (meta$mode$zoom){
meta$limits[1:2] = meta$limits[1:2] - meta$pos[1] + meta$start[1]
if (meta$limits[1,1]<extend_ranges(meta$data$xtmp)[1]) {
meta$limits[1:2] = meta$limits[1:2] - meta$limits[1,1] + extend_ranges(meta$data$xtmp)[1]
} else if (meta$limits[2,1]>extend_ranges(meta$data$xtmp)[2]) {
meta$limits[1:2] = meta$limits[1:2] - meta$limits[2,1] + extend_ranges(meta$data$xtmp)[2]
}
meta$xat = axis_loc(meta$limits[1:2])
meta$xlabels = format(meta$xat)
return()
}
rect = as.matrix(qrect(update_brush_size(meta)))
hits = rectLookup(tree, rect[1, ], rect[2, ])
if (length(hits)<1) {
selected(tdata) = FALSE
return()
}
selected(tdata) = meta$data$order[hits]
}
mouse_release = function(layer, event){
mouse_move(layer, event)
if (meta$mode$serie) {
meta$limits[1:2] = extend_ranges(range(meta$data$xtmp, na.rm = TRUE))
tree <<- createTree(data.frame(x=meta$data$xtmp,y=meta$data$ytmp))
}
}
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$keys = paste("Wheel: Zoom",ifelse(sign(event$delta())>0,"in","out"))
tmprange = extend_ranges(unlist(meta$data$xtmp))
meta$limits[1,1] = max(meta$limits[1,1],min(tmprange))
meta$limits[2,1] = min(meta$limits[2,1],max(tmprange))
meta$mode$zoom = ifelse(meta$limits[1,1]<=min(tmprange) & meta$limits[2,1]>=max(tmprange), FALSE, TRUE)
meta$xat = axis_loc(meta$limits[1:2,1])
meta$xlabels = format(meta$xat)
qupdate(layer.keys)
}
identify_hover = function(item, event, ...) {
if (!meta$brush$identify && !meta$mode$serie) return()
meta$brush$cursor = 2L
meta$pos = as.numeric(event$pos())
rect = as.matrix(identify_rect(meta))
if (meta$mode$serie){
xdiff = diff(meta$limits[1:2])*0.9/min(sort(table(meta$data$vidgroup),decreasing=TRUE)[1],50)
ydiff = diff(meta$limits[3:4])*0.9/meta$ngroup$vid
} else {
xdiff = meta$radius/layer.root$size$width() * diff(meta$limits[1:2])
ydiff = meta$radius/layer.root$size$height() * diff(meta$limits[3:4])
}
rect = rect + matrix(c(-xdiff,xdiff,-ydiff,ydiff),nrow=2)
meta$identified = rectLookup(tree, rect[1, ], rect[2, ])
if (!length(hits <- meta$identified)) return()
if (meta$mode$serie){
hitgroup = meta$data[hits,c('xtmp','ytmp','vargroup','idgroup','vidgroup'),drop=FALSE]
if (length(unique(hitgroup$vidgroup))>1){
hitgroup$dist = sqrt(((hitgroup$xtmp-meta$pos[1])/xdiff)^2+((hitgroup$ytmp-meta$pos[2])/ydiff)^2)
hitdist = tapply(hitgroup$dist,hitgroup$vidgroup,function(x){sum(1/(x+0.5))})
hitgroupname = names(hitdist)[which.max(hitdist)]
hitgroup = hitgroup[hitgroup$vidgroup==hitgroupname,,drop=FALSE]
}
hitsall = which(meta$data$vidgroup==hitgroup$vidgroup[1])
selected(tdata) = meta$data$order[hitsall]
qupdate(layer.brush)
return()
}
qupdate(layer.identify)
}
key_press = function(layer, event){
common_key_press(layer, event, tdata, meta)
keys = c('M','G','F','U','D','R','Y','H','V','T','O','P','Left','Right','Up','Down')
meta$shiftKey = shift_on(event)
key = keys[match_key(keys,event)]
if (!length(key)) return()
switch(key,
M = switch_serie_mode(meta, tdata),
G = shift_wrap_gear(meta),
F = switch_fold_mode(meta, tdata),
U = separate_group(meta),
D = mix_group(meta),
R = switch_area_mode(meta),
Y = y_wrap_forward(meta,tdata),
H = horizontal_facet(meta),
V = vertical_facet(meta),
T = transpose_facet(meta),
O = rotate_h_facet(meta),
P = rotate_v_facet(meta),
Left = x_wrap_backward(meta,tdata),
Right = x_wrap_forward(meta,tdata),
Up = size_up(meta),
Down = size_down(meta)
)
tree <<- createTree(data.frame(x=meta$data$xtmp,y=meta$data$ytmp))
qupdate(layer.point)
qupdate(layer.line)
qupdate(layer.area)
}
key_release = function(layer, event){
common_key_release(layer, event, tdata, meta)
}
############
## layers ##----------
############
point_draw = function(layer,painter){
col_fill = alpha(tdata$.color[meta$data$order], meta$data$fill*meta$alpha)
col_stroke = alpha(tdata$.border[meta$data$order], meta$data$stroke*meta$alpha)
qdrawGlyph(painter, qglyphCircle(r = meta$radius), meta$data$xtmp, meta$data$ytmp,
fill=col_fill, stroke=col_stroke)
}
line_draw = function(layer,painter){
qlineWidth(painter) = meta$radius / 2
compute_line(meta, tdata)
qdrawSegment(painter,meta$line$df$xs,meta$line$df$ys,
meta$line$df$xe,meta$line$df$ye,stroke=meta$line$df$col)
}
area_draw = function(layer,painter){
if (! meta$mode$area) return()
compute_area(meta, tdata, fun.base)
qdrawPolygon(painter, meta$area$poly$x, meta$area$poly$y,
stroke=alpha(meta$area$color,0.01), fill=meta$area$color)
}
brush_draw = function(layer, painter) {
if (any(is.na(meta$pos))) return()
hits = selected(tdata)[meta$data$order]
if (any(hits)) {compute_area(meta, tdata, fun.base); selected_draw(meta,b,hits,painter)}
if (meta$mode$zoom || meta$mode$serie) return()
draw_brush(layer, painter, tdata, meta)
}
identify_draw = function(item, painter, exposed, ...) {
if (!meta$brush$identify || !length(hits <- meta$identified)) return()
if (meta$ngroup$id==1) {
info = data.frame(meta$varname$x,meta$data[hits,c('x','yorig','vargroup',meta$varname$identify),drop=FALSE])
} else {
info = data.frame(meta$varname$x, meta$data[hits,c('x','yorig','vargroup',meta$varname$identify,'idgroup'),drop=FALSE])
}
meta$identify.labels = sprintf('%s: %s\n%s: %s',
meta$varname$x, paste(info[, 2], collapse = ', '),
info$vargroup[1], paste(info[, 3], collapse = ', '))
if (meta$ngroup$id>1) {
meta$identify.labels = paste(meta$identify.labels,"\nGroup:",paste(info$idgroup,collapse=', '))
}
if (!is.null(meta$varname$identify)) {
for (i in 1:length(meta$varname$identify)) {
meta$identify.labels = paste(meta$identify.labels,"\n",meta$varname$identify[i],": ",paste(info[,4+i],collapse=', '),sep='')
}
}
if (length(hits)>1){
meta$identify.labels = paste(" ",length(hits)," points\n",meta$identify.labels,sep='')
}
draw_identify(layer, painter, tdata, meta)
if (all(tdata$.size==tdata$.size[1])) {
qdrawGlyph(painter, qglyphCircle(r = sqrt(meta$brush$size) * meta$radius),
meta$data$xtmp[hits], meta$data$ytmp[hits], stroke = meta$brush$color, fill = NA)
} else {
qdrawCircle(painter, meta$data$xtmp[hits], meta$data$ytmp[hits],
r = sqrt(meta$brush$size) * tdata$.size[meta$data$order][hits],
stroke = meta$brush$color, fill = NA)
}
}
stats_draw = function(layer, painter){
if (meta$ngroup$id > 1) return()
if (meta$ngroup$xwrap == 1){
ytmpacf = unname(tapply(meta$data$yscaled,meta$data$vargroup,function(z) acf(z,lag.max=max(30,max(meta$steplen$xwrap)),plot=FALSE)$acf[meta$steplen$xwrap[1]+1]))
tmpprint = paste(meta$varname$y,": ACF(lag=",meta$steplen$xwrap[1],"):",round(ytmpacf,2),sep="")
} else if (meta$ngroup$xwrap==2) {
ytmpcor = as.vector(by(meta$data[,c('ytmp','xwrapgroup')],meta$data$vargroup,function(x){
cor(x$ytmp[x$xwrapgroup==1][1:sum(x$xwrapgroup==2)],x$ytmp[x$xwrapgroup==2])
}))
tmpprint = paste(meta$varname$y,": Corr. of two series = ",round(ytmpcor,2),sep="")
} else {
if (nrow(meta$data)>1000) print(paste("Before the model:", Sys.time()))
ytmpR2 = as.vector(by(meta$data[,c('xtmp','ytmp')],meta$data$vargroup,function(x){
res=summary(lm(x$ytmp~factor(x$xtmp)))$r.squared
}))
tmpprint = paste(meta$varname$y,": R square = ",round(ytmpR2,2),sep="")
if (nrow(meta$data)>1000) print(paste("After the model:", Sys.time()))
}
if (meta$mode$varUP) {
qdrawText(painter,tmpprint,
rep(meta$limits[1,1],meta$ngroup$y),meta$yat-diff(meta$yat[1:2])/2,
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')
}
}
#####################
## draw the canvas ##----------
#####################
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)
layer.keys = key_layer(meta)
layer.point = qlayer(paintFun = point_draw,
limits = qrect(meta$limits),
hoverMoveFun = identify_hover,
mousePressFun = mouse_press,
mouseReleaseFun = mouse_release,
mouseMoveFun = mouse_move,
wheelFun = mouse_wheel,
keyPressFun = key_press,
keyReleaseFun = key_release,
focusInFun = function(layer, event) {
common_focus_in(layer, event, data, meta)
}, focusOutFun = function(layer, event) {
common_focus_out(layer, event, data, meta)
}, clip=TRUE)
layer.line = qlayer(paintFun=line_draw,limits=qrect(meta$limits),clip=TRUE)
layer.area = qlayer(paintFun=area_draw,limits=qrect(meta$limits),clip=TRUE)
layer.brush = qlayer(paintFun=brush_draw, limits=qrect(meta$limits))
layer.identify = qlayer(paintFun=identify_draw, limits=qrect(meta$limits))
layer.keys = key_layer(meta)
if (series.stats) layer.stats = qlayer(paintFun=stats_draw, limits=qrect(meta$limits))
layer.root[0, 2] = layer.title
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 (series.stats) layer.root[1, 2] = layer.stats
layer.root[1, 2] = layer.area
layer.root[1, 2] = layer.line
layer.root[1, 2] = layer.point
layer.root[1, 2] = layer.brush
layer.root[1, 2] = layer.identify
layer.root[1, 2] = layer.keys
## 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(tdata, function(i, j) {
switch(j, .brushed = qupdate(layer.brush),
.color = {
qupdate(layer.point)
qupdate(layer.line)
qupdate(layer.area)
}, {
qupdate(layer.grid); qupdate(layer.xaxis); qupdate(layer.yaxis)
layer.point$invalidateIndex()
layer.line$invalidateIndex()
layer.area$invalidateIndex()
qupdate(layer.point)
qupdate(layer.line)
qupdate(layer.area)
})
})
qconnect(layer.point, 'destroyed', function(x) {
remove_listener(tdata, d.idx)
})
meta$brush$cursorChanged$connect(function() {
set_cursor(view, meta$brush$cursor)
})
sync_limits(meta, layer.point, layer.line, layer.area, layer.brush, layer.identify,layer.keys,
if (series.stats){layer.stats} else {NA})
meta$manual.brush = function(pos) {
mouse_move(layer = layer.point, event = list(pos = function() pos))
}
# aspect ratio
if (is.null(asp)) {
a <- asp_ratio(meta$data$xtmp,meta$data$ytmp)
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)
}
view = qplotView(scene=scene)
view$setWindowTitle(meta$main)
view$resize(xWidth,yWidth)
attr(view, 'meta') = meta
view
}
Time.meta = setRefClass("Time_meta",
contains = "CommonMeta",
fields = properties(list(
varname = 'list', # including the variable names for y, x, idgroup
ngroup = 'list', # including the number of groups for y, idgroup
data = 'data.frame', # with x,yorig,xtmp,ytmp,vargroup,idgroup,xwrapgroup,finalgroup,order,htvar,htid,htywrap,htfinal,areabaseline
mode = 'list', # including area,yfold,xwrap,zoom,serie,idSep,varUP,varDOWN
line = 'list', # including df,firstrow,lastrow
area = 'list', # including x,y,poly,color
hits = 'list',
cutbound = 'list', # including orig,cut
ywrapline = 'list',
yfoldline = 'data.frame',
facet = 'list', # hdiv, vdiv
steplen = 'list',
singleVarLen = 'integer',
shiftKey = 'logical',
linkID = 'character',
radius = 'numeric',
ylab.init = 'character',
brush = 'BRUSH'
)))
## Create a new mutaframe for drawing time plots
##
## The new mutaframe is only used for the qtime function.
## @param regular_qdata a data frame or mutaframe used for time plot
## @param yVar a character vertor of all the variable names of interest
## @param link a character vector of the variable names, to link two mutaframes
## @inheritParams qdata
## @return a mutaframe with multiple y's
time_qdata = function(regular_qdata, yVar, link) {
yCol = length(yVar)
data = as.data.frame(regular_qdata)
usecol = colnames(data) %in% c(".brushed",".visible",".color",".border",".size")
setting = data[, usecol]
settingh = setting[0,]
data = data[, !usecol]
newdat = data.frame(.variable="A",.value=0,data[1,],stringsAsFactors=FALSE)[0,]
for (i in 1:yCol) {
tmpnewdat = data.frame(.variable=rep(yVar[i],nrow(data)),.value=data[,yVar[i]],data,stringsAsFactors=FALSE)
tmpnewdat[,yVar[i]] = TRUE
tmpnewdat[,yVar[-i]] = FALSE
newdat = rbind(newdat, tmpnewdat)
settingh = rbind(settingh, setting)
}
newdat$.variable = factor(newdat$.variable,levels=yVar)
rownames(newdat) = 1:nrow(newdat)
newdat = qdata(newdat,
color = if (yCol>1 && all(settingh[,".color"]=='gray15')) {
.variable} else {as.character(settingh[,".color"])},
border = if (yCol>1 && all(settingh[,".border"]=='gray15')) {
.variable} else {as.character(settingh[,".border"])},
size = settingh[,".size"], brushed = settingh[,".brushed"],
visible = settingh[,".visible"])
link_cat(newdat,link,regular_qdata,link)
attr(newdat,"regular_nrow") = nrow(data)
return(newdat)
}
# Initialize the Time.meta
time_meta_initialize = function(meta, call, data, hdiv, vdiv,
shift, alpha, size, asp,
main, xlab, ylab, infolab, ...){
meta$singleVarLen = attr(data,"regular_nrow")
data = as.data.frame(data)
meta$data = data.frame(x = as.numeric(data[,meta$varname$x]),
yorig = data$.value)
## X axis setting
meta$data$xtmp = meta$data$xtmp0 = meta$data$x
meta$xlab = ifelse(is.null(xlab), meta$varname$x, xlab)
## Y axis setting
meta$varname$y = as.character(unique(data$.variable))
meta$ngroup$y = length(meta$varname$y)
meta$data$vargroup = factor(data$.variable,levels=meta$varname$y)
meta$data$yscaled = meta$data$yorig
ylist = data[,meta$varname$y,drop=FALSE]
if (meta$ngroup$y > 1) {
for (i in 1:meta$ngroup$y) {
tmprow = ylist[,i]
tmprowdat = meta$data$yorig[tmprow]
meta$data$yscaled[tmprow] = (tmprowdat - min(tmprowdat, na.rm = TRUE))/
diff(range(tmprowdat, na.rm = TRUE))
}
}
meta$data$ytmp = meta$data$yscaled
meta$ylab = ifelse(is.null(ylab), paste(meta$varname$y,collapse=', '), ylab)
meta$ylab.init = meta$ylab
## Group for panel data
meta$varname$g = union(vdiv, hdiv)
if (length(meta$varname$g)==0) {
meta$ngroup$id = 1
meta$data$idgroup = 1
} else {
meta$ngroup$id = nrow(unique(data[,meta$varname$g,drop=FALSE]))
meta$data$idgroup = bind_var(data,meta$varname$g)
}
## Other groups
meta$data$xwrapgroup = 1
meta$ngroup$xwrap = 1
meta$data$ywrapgroup = 1
meta$ngroup$ywrap = 1
## Group y-axis
meta$data$htvar=0
meta$data$htid=0
meta$data$htywrap=0
meta$data$htperiod=0
## facet
meta$data$vfacet = 0
meta$data$hfacet = 0
meta$varname$hfacet = hdiv
meta$varname$vfacet = vdiv
## order the data by vargroup, idgroup, and x
orderEnter = order(meta$data$vargroup, meta$data$idgroup, meta$data$x, decreasing=FALSE)
meta$data$order = 1:nrow(meta$data)
meta$data = meta$data[orderEnter,]
## Mode settings
meta$mode$area = FALSE
meta$mode$yfold = FALSE
meta$mode$xwrap = FALSE
meta$mode$ywrap = FALSE
meta$mode$period = FALSE
meta$mode$zoom = FALSE
meta$mode$serie = FALSE
meta$mode$idSep = FALSE
meta$mode$varUP = FALSE
meta$mode$varDOWN = FALSE
meta$mode$hfacet = 0
meta$mode$vfacet = 0
## Other
meta$steplen$xwrap = shift
meta$steplen$xzoom = diff(range(meta$data$x,na.rm=TRUE))+1
meta$steplen$ywrap = 0.9
meta$steplen$yzoom = 1
meta$steplen$id = 0 # vertconst
meta$shiftKey = FALSE
meta$linkID = NULL
meta$varname$identify = infolab
## Range, axes, etc.
meta$limits = matrix(c(extend_ranges(range(meta$data$xtmp, na.rm = TRUE)),
extend_ranges(range(meta$data$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)
## Radius, color, etc.
meta$radius = size
meta$alpha = alpha
meta$data$stroke = 1
meta$data$fill = 1
## Brush etc.
meta$pos = c(NA, NA)
meta$start = c(NA, NA)
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
## include the variables needed
include_var(c(hdiv,vdiv,infolab),meta, data)
}
# bind variables into factor with reasonable levels
bind_var = function(dat, varnames, simplify=TRUE) {
classes = sapply(dat[,varnames,drop=FALSE], function(a) class(a)[1])
if (length(varnames)==1) {
newgroup = dat[,varnames]
if (!classes %in% c('factor','ordered'))
newgroup = factor(as.character(newgroup), levels=sort(unique(newgroup)))
} else {
group = unname(apply(dat[,varnames],1,paste,collapse=','))
level = list()
levelbind = 'start'
for (i in 1:length(varnames)){
tmpdat = dat[,varnames[i]]
level[[i]] = if (classes[i] %in% c('factor','ordered')) {levels(tmpdat)} else {as.character(sort(unique(tmpdat)))}
levelbind = as.vector(t(outer(levelbind,level[[i]],paste,sep=',')))
}
levelbind = gsub('^start,','',levelbind)
if (simplify) levelbind = levelbind[levelbind %in% group]
newgroup = factor(group,levels=levelbind)
}
return(newgroup)
}
# Include some variables in meta$data
include_var = function(varname, meta, dat) {
if (length(varname) && length(setdiff(colnames(meta$data),varname))) {
varname = setdiff(varname, colnames(meta$data))
meta$data = cbind(meta$data, dat[meta$data$order,varname])
colnames(meta$data)[1:length(varname) + ncol(meta$data) - length(varname)] = varname
}
}
# Update the groups of points to make the line
update_meta_group = function(meta){
meta$data$finalgroup = paste(meta$data$vargroup, meta$data$idgroup, meta$data$xwrapgroup)
meta$data$vidgroup = paste(meta$data$vargroup, meta$data$idgroup)
#meta$data$htfinal = sum(meta$data$htvar, meta$data$htid, meta$data$htywrap)
meta$ngroup$final = length(unique(meta$data$finalgroup))
meta$ngroup$vid = length(unique(meta$data$vidgroup))
meta$ngroup$xwrap = length(unique(meta$data$xwrapgroup))
meta$mode$xwrap = ifelse(meta$ngroup$xwrap>1,TRUE,FALSE)
}
# Update the colors of points when x-wrapping
update_meta_xwrap_color = function(meta, data){
color_seq = seq(1,0,length=meta$ngroup$xwrap+1)
meta$data$fill = color_seq[meta$data$xwrapgroup]
meta$data$stroke = color_seq[meta$data$xwrapgroup]
}
# Update the xtmp when x-wrapping
update_meta_xwrap = function(meta){
meta$data$xtmp = meta$data$x-min(meta$data$x,na.rm=TRUE)+1
meta$data$xwrapgroup = ceiling(meta$data$xtmp/meta$steplen$xzoom)
meta$data$xtmp = meta$data$xtmp %% meta$steplen$xzoom
if (all(meta$data$xtmp == meta$data$xtmp[1])){
message('Can not wrap forward any longer. Please use the left arrow to wrap backward.')
}
if (sum(meta$data$xtmp==0)){
meta$data$xwrapgroup[meta$data$xtmp==0] = meta$data$xwrapgroup[which(meta$data$xtmp==0)-1]
meta$data$xtmp[meta$data$xtmp==0] = meta$steplen$xzoom
}
meta$data$xtmp = meta$data$xtmp + min(meta$data$x,na.rm=TRUE)-1
meta$data$xtmp0 = meta$data$xtmp
}
# Update the height of variables -- htvar
update_meta_htvar = function(meta){
meta$data$htvar = if (meta$mode$varUP & meta$steplen$id>0) {
(as.integer(meta$data$vargroup)-1) * (1 + (meta$ngroup$id-1)*meta$steplen$id) * 1.02
} else if (meta$mode$varUP) {
(as.integer(meta$data$vargroup)-1) * 1.02
} else 0
if (meta$mode$ywrap) meta$data$htvar = meta$data$htvar * meta$steplen$yzoom * 1.05
}
# Get the horizontal lines to cut the series
compute_cutbound = function(meta){
tmp = if (meta$mode$yfold){
meta$data$hrznbaseline + abs(meta$data$hrznydiff)
} else if (meta$steplen$id==0) {
meta$data$yscaled
} else {(meta$data$yscaled-min(meta$data$yscaled,na.rm=TRUE))/diff(range(meta$data$yscaled,na.rm=TRUE))}
meta$cutbound$diff = tapply(tmp,meta$data$vargroup,function(x){
diff(range(x))*meta$steplen$yzoom})
meta$cutbound$orig = tapply(tmp,meta$data$vargroup,function(x){
d = diff(range(x))*meta$steplen$yzoom
dcut = seq(from=min(x),by=d,length=meta$ngroup$ywrap+1)
return(dcut)})
meta$cutbound$cut = lapply(meta$cutbound$orig,function(x){
x[1]=x[1]-1
x[length(x)]=x[length(x)]+1
return(x)})
}
# Set up meta$line
compute_line = function(meta, data){
update_meta_group(meta)
tmpcolor = alpha(data$.color[meta$data$order],meta$data$fill*meta$alpha)
if (meta$mode$ywrap){
meta$line$df = data.frame()
for (i in 1:length(meta$ywrapline)){
for (j in 1:length(meta$ywrapline[[i]])){
tmpdat = meta$ywrapline[[i]][[j]]$data
tmprow = sapply(tmpdat$id,function(x) which(rownames(meta$data)==x))
tmpn = nrow(tmpdat)
tmpline = data.frame(xs=tmpdat$xtmp[-tmpn],
ys=tmpdat$ytmp[-tmpn],
xe=tmpdat$xtmp[-1],
ye=tmpdat$ytmp[-1],
col=tmpcolor[tmprow][-tmpn],
id=tmprow[-tmpn])
meta$line$df = rbind(meta$line$df, tmpline[complete.cases(tmpline),])
}
}
return()
}
if (meta$mode$yfold) {
tmpcolor = alpha(meta$yfoldline$.color,meta$yfoldline$fill*meta$alpha)
tmpdat = meta$yfoldline
tmpid = tmpdat$id
} else {
tmpdat = meta$data
tmpid = 1:nrow(meta$data)
}
meta$line$lastrow = which(c(diff(as.integer(factor(tmpdat$finalgroup)))!=0,TRUE))
meta$line$firstrow = c(1,(meta$line$lastrow[-length(meta$line$lastrow)]+1))
meta$line$df = data.frame(xs=tmpdat$xtmp[-meta$line$lastrow],
ys=tmpdat$ytmp[-meta$line$lastrow],
xe=tmpdat$xtmp[-meta$line$firstrow],
ye=tmpdat$ytmp[-meta$line$firstrow],
col=tmpcolor[-meta$line$lastrow],
id=tmpid[-meta$line$lastrow])
}
# Set up meta$area
compute_area = function(meta, data, fun.base){
compute_line(meta, data)
tmpcolor = alpha(data$.color[meta$data$order],meta$data$fill*meta$alpha/2)
meta$area$x = data.frame(x1=meta$line$df$xs,x2=meta$line$df$xe,x3=meta$line$df$xe,
x4=meta$line$df$xs,x5=meta$line$df$xs,x6=NA)
if (meta$mode$ywrap){
areabaseline = (meta$data$htvar + meta$data$htid + meta$data$vfacet)[meta$line$df$id]
meta$area$y = data.frame(y1=areabaseline,y2=areabaseline,y3=meta$line$df$ye,
y4=meta$line$df$ys,y5=areabaseline,y6=NA)
meta$area$color = tmpcolor[meta$line$df$id]
} else {
areabaseline = tapply(meta$data$ytmp,meta$data$vargroup,fun.base)
meta$data$areabaseline = meta$data$htvar + meta$data$htid + meta$data$htperiod + meta$data$vfacet
if (all(meta$data$areabaseline==0)) meta$data$areabaseline = areabaseline[meta$data$vargroup]
if (meta$mode$yfold) {
tmpcolor = alpha(meta$yfoldline$.color,meta$yfoldline$fill*meta$alpha/2)
tmpdat = meta$yfoldline
areabaseline = tapply(tmpdat$ytmp,tmpdat$vargroup,fun.base)
areabaseline2 = tapply(meta$data$htid,meta$data$finalgroup,`[`,1)
tmpdat$areabaseline = areabaseline[tmpdat$vargroup] + areabaseline2[tmpdat$finalgroup]
} else {
tmpdat = meta$data
}
meta$area$y = data.frame(y1=tmpdat$areabaseline[-meta$line$lastrow],
y2=tmpdat$areabaseline[-meta$line$lastrow],
y3=meta$line$df$ye, y4=meta$line$df$ys,
y5=tmpdat$areabaseline[-meta$line$lastrow],
y6=NA)
meta$area$color = tmpcolor[-meta$line$lastrow]
}
meta$area$poly = data.frame(x=as.vector(as.matrix(t(meta$area$x))),
y=as.vector(as.matrix(t(meta$area$y))),
group=rep(1:nrow(meta$area$x),each=6))
}
# Draw the selected data in qtime
selected_draw = function(meta,b,hits,painter){
qdrawGlyph(painter, qglyphCircle(r = meta$radius*2), meta$data$xtmp[hits],
meta$data$ytmp[hits], stroke = meta$brush$color, fill = meta$brush$color)
qlineWidth(painter) = max(meta$radius,1)
idx = (hits[-length(hits)] & hits[-1])[-meta$line$lastrow]
qdrawSegment(painter,meta$area$x[idx,4],meta$area$y[idx,4],
meta$area$x[idx,3],meta$area$y[idx,3],stroke=meta$brush$color)
if (meta$mode$area){
tmpx=as.vector(as.matrix(t(meta$area$x[idx,])))
tmpy=as.vector(as.matrix(t(meta$area$y[idx,])))
qdrawPolygon(painter, tmpx, tmpy, stroke=alpha(meta$brush$color,0.01), fill=alpha(meta$brush$color,0.8))
}
}
# Set limits for xaxis in qtime
meta_xaxis = function(meta) {
if(meta$mode$hfacet) {
tmpidx = !duplicated(meta$data[,meta$varname$hfacet[1:meta$mode$hfacet]])
meta$xat = meta$data$hfacet[tmpidx]
meta$xlabels = as.character(bind_var(meta$data,meta$varname$hfacet[1:meta$mode$hfacet]))[tmpidx]
tmporder = order(meta$xat)
meta$xat = meta$xat[tmporder]
meta$xlabels = meta$xlabels[tmporder]
meta$xlab = paste(meta$varname$hfacet[1:meta$mode$hfacet],collapse=',')
} else {
meta$limits[1:2] = extend_ranges(meta$data$xtmp)
meta$xat = axis_loc(meta$limits[1:2])
meta$xlabels = format(meta$xat)
meta$xlab = meta$varname$x
}
}
# Set limits for yaxis in qtime
meta_yaxis = function(meta) {
if(meta$mode$vfacet) {
tmpidx = !duplicated(meta$data[,meta$varname$vfacet[1:meta$mode$vfacet]])
meta$yat = meta$data$vfacet[tmpidx]
meta$ylabels = format(bind_var(meta$data,meta$varname$vfacet[1:meta$mode$vfacet])[tmpidx],justify='right')
tmporder = order(meta$yat)
meta$yat = meta$yat[tmporder]
meta$ylabels = meta$ylabels[tmporder]
meta$ylab = paste(meta$varname$vfacet[1:meta$mode$vfacet],collapse=',')
} else if (meta$steplen$id) {
if (meta$mode$varUP) {
meta$yat = (meta$data$htid+meta$data$htvar)[!duplicated(meta$data$vidgroup)]+0.5*meta$steplen$id
meta$ylabels = format(unique(meta$data$vidgroup),justify='right')
} else {
meta$yat = meta$data$htid[!duplicated(meta$data$idgroup)]+0.5*meta$steplen$id*ifelse(meta$mode$varUP,meta$ngroup$y,1)
meta$ylabels = format(unique(meta$data$idgroup),justify='right')
}
meta$ylab = paste(meta$varname$g,collapse=',')
} else if (meta$mode$varUP) {
tmpyat = sort(unique(meta$data$htvar))
meta$yat = tmpyat + diff(tmpyat[1:2])/2
meta$ylabels = meta$varname$y
meta$ylab = ""
} else if (meta$mode$varDOWN) {
meta$yat = axis_loc(meta$limits[3:4])
meta$ylabels = format(meta$yat,justify='right')
meta$ylab = paste(meta$varname$y,collapse=', ')
meta$mode$varUP = FALSE
} else {
#if (meta$ngroup$id==1 | !meta$steplen$id){
meta$yat = axis_loc(meta$limits[3:4])
#} else {
# meta$yat = (1:meta$ngroup$id-0.5)*meta$steplen$id
#}
#if (meta$steplen$id==0) {
meta$ylabels = format(meta$yat,justify='right')
meta$ylab = meta$ylab.init
#} else {
# meta$ylabels = format(unique(meta$data$idgroup))
# meta$ylab = meta$varname$g
#}
}
}
# 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$mode$zoom) {
meta$mode$zoom = FALSE
meta$mode$serie = FALSE
return()
}
if (meta$ngroup$id>1 & meta$ngroup$y==1){
meta$mode$serie = !meta$mode$serie
if (!meta$mode$serie) {
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$mode$serie = FALSE
}
}
} else if (meta$ngroup$vid>1) {
meta$mode$serie = !meta$mode$serie
}
}
# key G for shifting the wrapping gear, i.e. changing the period/frequency
shift_wrap_gear = function(meta){
meta$steplen$xwrap = c(meta$steplen$xwrap[-1],meta$steplen$xwrap[1])
}
# key R for turning on/off the area mode
switch_area_mode = function(meta){
meta$mode$area = !meta$mode$area
}
# key F for fold/unfold the time series by mean
switch_fold_mode = function(meta,data){
meta$mode$yfold = !meta$mode$yfold
tmpdat = if (meta$steplen$id>0 & (!meta$mode$varUP)) {
(meta$data$yscaled - min(meta$data$yscaled))/diff(range(meta$data$yscaled))
} else {meta$data$yscaled}
if (meta$mode$yfold) {
hrznbaseline = tapply(tmpdat,meta$data$vargroup,mean,na.rm=TRUE)
meta$data$hrznbaseline = hrznbaseline[meta$data$vargroup]
meta$data$hrznydiff = tmpdat - meta$data$hrznbaseline
meta$data$ytmp = abs(meta$data$hrznydiff) + meta$data$hrznbaseline + meta$data$htvar + meta$data$htid
meta$data$hrzncolor = data$.color[meta$data$order]
meta$data$hrznborder = data$.border[meta$data$order]
data$.color[meta$data$order] = c('#E69F00','grey15','#56B4E9')[sign(meta$data$hrznydiff)+2]
data$.border = data$.color
meta$yfoldline = cbind(meta$data[,c('xtmp','ytmp','hrznydiff','vargroup','finalgroup','fill')],data[meta$data$order,'.color',drop=FALSE])
meta$yfoldline$finalgroup = as.integer(factor(meta$yfoldline$finalgroup))
rownames(meta$yfoldline) = 1:nrow(meta$yfoldline)
idx = which((abs(diff(sign(meta$yfoldline$hrznydiff)))==2) & (diff(meta$yfoldline$finalgroup)==0))
zeroline = data.frame(xtmp=(meta$yfoldline$xtmp[idx]*abs(meta$yfoldline$hrznydiff[idx+1])+meta$yfoldline$xtmp[idx+1]*abs(meta$yfoldline$hrznydiff[idx]))/(abs(meta$yfoldline$hrznydiff[idx])+abs(meta$yfoldline$hrznydiff[idx+1])),
ytmp=meta$data$hrznbaseline[idx] + meta$data$htvar[idx] + meta$data$htid[idx],
hrznydiff=NA,
vargroup=meta$yfoldline$vargroup[idx],
finalgroup=meta$yfoldline$finalgroup[idx],
fill=meta$yfoldline$fill[idx],
.color=meta$yfoldline$.color[idx+1])
rownames(zeroline) = idx+0.5
meta$yfoldline = rbind(meta$yfoldline,zeroline)
meta$yfoldline = meta$yfoldline[order(as.numeric(rownames(meta$yfoldline))),]
meta$yfoldline$id = round(as.numeric(rownames(meta$yfoldline)))
} else {
meta$data$ytmp = tmpdat + meta$data$htvar + meta$data$htid
data$.color[meta$data$order] = meta$data$hrzncolor
data$.border[meta$data$order] = meta$data$hrznborder
}
if (meta$shiftKey | !meta$mode$yfold) {
meta$limits[3:4] = extend_ranges(range(meta$data$ytmp,na.rm=TRUE))
meta_yaxis(meta)
}
}
# key U for separating the groups by shifting up
separate_group = function(meta){
if (meta$ngroup$y>1 & meta$shiftKey) {
meta$data$htvar = as.integer(meta$data$vargroup) - 1
meta$data$htid = (as.integer(meta$data$idgroup)-1)*meta$steplen$id*meta$ngroup$y
meta$data$ytmp = meta$data$yscaled + meta$data$htvar + meta$data$htid
meta$mode$varUP = TRUE
} else if (meta$ngroup$id>1) {
meta$steplen$id = meta$steplen$id + 0.05
if (meta$steplen$id>1) meta$steplen$id = 1
meta$data$htid = (as.integer(meta$data$idgroup)-1)*meta$steplen$id
if (meta$mode$varUP) meta$data$htvar = (as.integer(meta$data$vargroup)-1) * (1+(meta$ngroup$id-1)*meta$steplen$id)
meta$data$ytmp = (meta$data$yscaled-min(meta$data$yscaled,na.rm=TRUE))/diff(range(meta$data$yscaled,na.rm=TRUE)) + meta$data$htid + meta$data$htvar
} else if (meta$ngroup$y == 1 && meta$ngroup$id == 1 && meta$ngroup$xwrap>1 && !meta$mode$ywrap) {
meta$mode$period = TRUE
meta$data$htperiod = as.integer(meta$data$xwrapgroup) - 1
meta$data$ytmp = (meta$data$yscaled-min(meta$data$yscaled,na.rm=TRUE))/diff(range(meta$data$yscaled,na.rm=TRUE)) + meta$data$htperiod
}
meta$limits[3:4] = extend_ranges(range(meta$data$ytmp,na.rm=TRUE))
meta_yaxis(meta)
}
# key D for mixing the groups
mix_group = function(meta){
# meta$mode$varUP = FALSE
if (meta$ngroup$y>1 & meta$shiftKey) {
meta$data$htvar = 0
meta$data$htid = (as.integer(meta$data$idgroup)-1)*meta$steplen$id
meta$data$ytmp = meta$data$yscaled + meta$data$htid + meta$data$htvar
meta$mode$varUP = FALSE
meta$mode$varDOWN = TRUE
} else if (meta$ngroup$y == 1 && meta$ngroup$id == 1 && meta$mode$period) {
meta$mode$period = FALSE
meta$data$htperiod = 0
meta$data$ytmp = meta$data$yscaled + meta$data$htid + meta$data$htvar
} else {
if (meta$ngroup$id>1) {
meta$steplen$id = meta$steplen$id - 0.05
if (meta$steplen$id<0) meta$steplen$id = 0
if (!meta$steplen$id) {
meta$data$htid = 0
#meta$data$htvar = as.integer(meta$data$vargroup) - 1
meta$data$ytmp = meta$data$yscaled + meta$data$htid + meta$data$htvar
meta$limits[3:4] = extend_ranges(range(meta$data$ytmp,na.rm=TRUE))
} else {
meta$data$htid = (as.integer(meta$data$idgroup)-1)*meta$steplen$id
if (meta$mode$varUP) meta$data$htvar = (as.integer(meta$data$vargroup)-1) * (1+(meta$ngroup$id-1)*meta$steplen$id)
meta$data$ytmp = (meta$data$yscaled-min(meta$data$yscaled,na.rm=TRUE))/diff(range(meta$data$yscaled,na.rm=TRUE)) + meta$data$htid + meta$data$htvar
}
}
}
meta$limits[3:4] = extend_ranges(range(meta$data$ytmp,na.rm=TRUE))
meta_yaxis(meta)
}
# update the horizontal faceting by the current setting
update_h_facet = function(meta){
if (meta$mode$hfacet == 0){
meta$data$hfacet = 0
meta$data$xtmp = meta$data$xtmp0
} else {
meta$data$hfacet = as.integer(bind_var(meta$data,meta$varname$hfacet[1:meta$mode$hfacet])) - 1
meta$data$hfacet = meta$data$hfacet * diff(range(meta$data$xtmp0,na.rm=TRUE))*1.1
meta$data$hfacet = meta$data$hfacet + min(meta$data$xtmp0)
meta$data$xtmp = meta$data$xtmp0 + meta$data$hfacet - min(meta$data$xtmp0)
}
meta$limits[1:2] = extend_ranges(range(meta$data$xtmp,na.rm=TRUE))
meta_xaxis(meta)
}
# update the vertical faceting by the current setting
update_v_facet = function(meta){
if (meta$mode$vfacet==0){
meta$data$vfacet = 0
meta$data$ytmp = meta$data$yscaled
} else {
meta$data$vfacet = as.integer(bind_var(meta$data,meta$varname$vfacet[1:meta$mode$vfacet])) - 1
meta$data$vfacet = meta$data$vfacet * diff(range(meta$data$yscaled,na.rm=TRUE))*1.02
meta$data$vfacet = meta$data$vfacet + min(meta$data$yscaled)
meta$data$ytmp = meta$data$yscaled + meta$data$vfacet - min(meta$data$yscaled)
}
meta$limits[3:4] = extend_ranges(range(meta$data$ytmp,na.rm=TRUE))
meta_yaxis(meta)
}
# key H for faceting the series horizontally
horizontal_facet = function(meta){
h = length(meta$varname$hfacet)
if (h==0) return()
if (meta$shiftKey) {
meta$mode$hfacet = max(meta$mode$hfacet-1, 0)
} else {
meta$mode$hfacet = min(meta$mode$hfacet+1, h)
}
update_h_facet(meta)
}
# key V for faceting the series vertically
vertical_facet = function(meta){
v = length(meta$varname$vfacet)
if (v==0) return()
if (meta$shiftKey) {
meta$mode$vfacet = max(meta$mode$vfacet-1, 0)
} else {
meta$mode$vfacet = min(meta$mode$vfacet+1, v)
}
update_v_facet(meta)
}
# key T for transposing the h/v faceting
transpose_facet = function(meta){
tmp = meta$varname$hfacet
meta$varname$hfacet = meta$varname$vfacet
meta$varname$vfacet = tmp
tmp = meta$mode$hfacet
meta$mode$hfacet = meta$mode$vfacet
meta$mode$vfacet = tmp
update_h_facet(meta)
update_v_facet(meta)
}
# key for rotating h-faceting
rotate_h_facet = function(meta){
h=length(meta$varname$hfacet)
if (meta$shiftKey) {
meta$varname$hfacet = meta$varname$hfacet[c(h,1:(h-1))]
} else {
meta$varname$hfacet = meta$varname$hfacet[c(2:h,1)]
}
update_h_facet(meta)
}
# key for rotating v-faceting
rotate_v_facet = function(meta){
v = length(meta$varname$vfacet)
if (meta$shiftKey) {
meta$varname$vfacet = meta$varname$vfacet[c(v,1:(v-1))]
} else {
meta$varname$vfacet = meta$varname$vfacet[c(2:v,1)]
}
update_v_facet(meta)
}
# key Right for x-wrapping
x_wrap_forward = function(meta,data){
if (meta$mode$serie) {
hits = selected(data)[meta$data$order]
if (sum(hits)) {
if (min(meta$data$xtmp[hits],na.rm=TRUE)<=max(meta$data$x,na.rm=TRUE)){
meta$data$xtmp[hits] = meta$data$xtmp[hits] + diff(range(meta$data$x,na.rm=TRUE))/meta$singleVarLen
}
meta_xaxis(meta)
}
return()
}
if (meta$shiftKey) {
meta$steplen$xzoom = max(meta$steplen$xwrap)
if (meta$steplen$xzoom<2) meta$steplen$xzoom = diff(range(meta$data$x,na.rm=TRUE))/4
update_meta_xwrap(meta)
} else {
crt_range = diff(range(meta$data$xtmp,na.rm=TRUE))+1
bd = max(c(3,min(abs(diff(meta$data$x)))))
while (diff(range(meta$data$xtmp,na.rm=TRUE))+1 >= crt_range &
meta$steplen$xzoom > max(c(bd,meta$steplen$xwrap[1])) ) {
meta$steplen$xzoom = meta$steplen$xzoom - meta$steplen$xwrap[1]
if (meta$steplen$xwrap[1]==1 & meta$steplen$xzoom<bd){
meta$steplen$xzoom = bd
} else if (meta$steplen$xwrap[1]!=1 & meta$steplen$xzoom<meta$steplen$xwrap[1]){
meta$steplen$xzoom = meta$steplen$xzoom %% meta$steplen$xwrap[1]
#if (meta$steplen$xzoom<=0) meta$steplen$xzoom = meta$steplen$xwrap[1]
}
update_meta_xwrap(meta)
}
}
update_meta_group(meta)
update_meta_xwrap_color(meta,data)
meta_xaxis(meta)
if (meta$mode$period){
meta$data$htperiod = as.integer(meta$data$xwrapgroup) - 1
meta$data$ytmp = (meta$data$yscaled-min(meta$data$yscaled,na.rm=TRUE))/diff(range(meta$data$yscaled,na.rm=TRUE)) + meta$data$htperiod
meta$limits[3:4] = extend_ranges(meta$data$ytmp)
}
}
# key Left for x-backward-wrapping
x_wrap_backward = function(meta,data){
if (meta$shiftKey) {
meta$data$xtmp = meta$data$xtmp0 = meta$data$x
meta$data$xwrapgroup = 1
meta$steplen$xzoom = diff(range(meta$data$x, na.rm=TRUE))+1
meta$mode$zoom = FALSE
if (meta$mode$period) {
meta$data$ytmp = meta$data$yscaled
meta$mode$period=FALSE
meta$limits[3:4] = extend_ranges(meta$data$ytmp)
meta_yaxis(meta)
}
} else {
hits = selected(data)[meta$data$order]
if (meta$mode$serie & sum(hits)) {
if (max(meta$data$xtmp[hits],na.rm=TRUE) >= min(meta$data$x,na.rm=TRUE)) {
meta$data$xtmp[hits] = meta$data$xtmp[hits] - diff(range(meta$data$x,na.rm=TRUE))/meta$singleVarLen
}
} else if (!meta$mode$serie) {
crt_range = diff(range(meta$data$xtmp,na.rm=TRUE))+1
while (diff(range(meta$data$xtmp,na.rm=TRUE))+1 <= crt_range &
meta$steplen$xzoom < diff(range(meta$data$x,na.rm=TRUE))+1) {
meta$steplen$xzoom = meta$steplen$xzoom + meta$steplen$xwrap[1]
if (meta$steplen$xzoom > diff(range(meta$data$x,na.rm=TRUE))+1) {
meta$steplen$xzoom = diff(range(meta$data$x,na.rm=TRUE))+1
}
update_meta_xwrap(meta)
}
if (meta$mode$period){
meta$data$htperiod = as.integer(meta$data$xwrapgroup) - 1
if (any(meta$data$htperiod > 0)) {
meta$data$ytmp = (meta$data$yscaled-min(meta$data$yscaled,na.rm=TRUE))/diff(range(meta$data$yscaled,na.rm=TRUE)) + meta$data$htperiod
} else {meta$mode$period=FALSE; meta$data$ytmp = meta$data$yscaled}
meta$limits[3:4] = extend_ranges(meta$data$ytmp)
meta_yaxis(meta)
}
}
}
update_meta_group(meta)
update_meta_xwrap_color(meta,data)
meta_xaxis(meta)
}
# key Y for y-wrapping, and Shift+Y for y-backward-wrapping
y_wrap_forward = function(meta,data){
if (meta$mode$xwrap) return()
# shift the ywrap for one step to the left or right
meta$steplen$yzoom = meta$steplen$yzoom * if (meta$shiftKey){1/meta$steplen$ywrap} else {meta$steplen$ywrap}
if (meta$steplen$yzoom>1) meta$steplen$yzoom=1
if (meta$steplen$yzoom<0.1) meta$steplen$yzoom=0.1
meta$data$htid = (as.integer(meta$data$idgroup)-1)*(meta$steplen$id+0.05) * meta$steplen$yzoom
meta$ngroup$ywrap = ceiling(1/meta$steplen$yzoom)
# when the ywrap mode is off, reset ytmp
if (meta$steplen$yzoom == 1){
update_meta_htvar(meta)
meta$mode$ywrap = FALSE
meta$data$ywrapgroup = 1
meta$data$ytmp = meta$data$htvar + meta$data$htid + if (meta$mode$yfold){
meta$data$hrznbaseline + abs(meta$data$hrznydiff)
} else if (meta$steplen$id==0) {
meta$data$yscaled
} else {(meta$data$yscaled-min(meta$data$yscaled,na.rm=TRUE))/diff(range(meta$data$yscaled,na.rm=TRUE))}
meta$limits[3:4] = extend_ranges(range(meta$data$ytmp,na.rm=TRUE))
meta_yaxis(meta)
return()
}
# when the ywrap mode is on
meta$mode$area = TRUE
meta$mode$ywrap = TRUE
compute_cutbound(meta)
update_meta_htvar(meta)
meta$data$ywrapgroup = 1
ytmp = if (meta$mode$yfold) {meta$data$hrznbaseline + abs(meta$data$hrznydiff)} else if (meta$steplen$id==0) {meta$data$yscaled} else {(meta$data$yscaled-min(meta$data$yscaled,na.rm=TRUE))/diff(range(meta$data$yscaled,na.rm=TRUE))}
# for each variable, calculate the new ywrapgroup and ytmp
for (i in 1:meta$ngroup$y){
tmprows = (meta$data$vargroup==meta$varname$y[i])
meta$data$ywrapgroup[tmprows] = as.integer(cut(ytmp[tmprows],meta$cutbound$cut[[i]]))
meta$data$ytmp[tmprows] = ytmp[tmprows] - meta$cutbound$orig[[i]][meta$data$ywrapgroup[tmprows]] + meta$data$htvar[tmprows] + meta$data$htid[tmprows]
}
# for each wrapped line, get the coordinates
meta$ywrapline = list()
for (i in unique(meta$data$vidgroup)){
tmpdata = meta$data[meta$data$vidgroup==i,,drop=FALSE]
tmpdata$yscaled = ytmp[meta$data$vidgroup==i]
tmpvargroup = tmpdata$vargroup[1]
for (j in 1:meta$ngroup$ywrap) {
meta$ywrapline[[i]][[j]] = list(data=tmpdata[,c('xtmp','ytmp'),drop=FALSE])
meta$ywrapline[[i]][[j]]$data$id = rownames(meta$ywrapline[[i]][[j]]$data)
dominant = which(tmpdata$ywrapgroup==j)
if (length(dominant) && all(dominant==1:nrow(tmpdata))) next
boundary = setdiff(1:nrow(tmpdata),dominant)
boundary_upper = boundary[tmpdata$ywrapgroup[boundary]>j]
dominant_left = boundary[c(diff(boundary)>1,TRUE)]
if (rev(dominant_left)[1]==nrow(tmpdata)) dominant_left = dominant_left[-length(dominant_left)]
meta$ywrapline[[i]][[j]]$dominant_left_upper = intersect(dominant_left,boundary_upper)
meta$ywrapline[[i]][[j]]$dominant_left_lower = setdiff(dominant_left,boundary_upper)
dominant_right = boundary[c(1,which(diff(boundary)>1)+1)]
if (dominant_right[1]==1) dominant_right = dominant_right[-1]
meta$ywrapline[[i]][[j]]$dominant_right_upper = intersect(dominant_right,boundary_upper)
meta$ywrapline[[i]][[j]]$dominant_right_lower = setdiff(dominant_right,boundary_upper)
meta$ywrapline[[i]][[j]]$recessive_up = which(tmpdata$ywrapgroup[-nrow(tmpdata)] < j & tmpdata$ywrapgroup[-1] > j)
meta$ywrapline[[i]][[j]]$recessive_dn = which(tmpdata$ywrapgroup[-nrow(tmpdata)] > j & tmpdata$ywrapgroup[-1] < j)
if (length(dominant)) {
meta$ywrapline[[i]][[j]]$data[-dominant,'ytmp'] = tmpdata$htvar[dominant][1] + tmpdata$htid[dominant][1]
} else {
meta$ywrapline[[i]][[j]]$data[,'ytmp'] = tmpdata$htvar[1] + tmpdata$htid[1]
}
if (length(boundary_upper)) meta$ywrapline[[i]][[j]]$data[boundary_upper,'ytmp'] = meta$ywrapline[[i]][[j]]$data[boundary_upper,'ytmp'] + meta$cutbound$diff[tmpvargroup]
crosspoint_x = function(x1,y1,x2,y2,h){
x1+(h-y1)/(y2-y1)*(x2-x1)
}
if (length(meta$ywrapline[[i]][[j]]$dominant_left_upper)){
addpoints_left = meta$ywrapline[[i]][[j]]$data[meta$ywrapline[[i]][[j]]$dominant_left_upper,c('xtmp','ytmp','id'),drop=FALSE]
addpoints_left$xtmp = crosspoint_x(tmpdata$xtmp[meta$ywrapline[[i]][[j]]$dominant_left_upper],
tmpdata$yscaled[meta$ywrapline[[i]][[j]]$dominant_left_upper],
tmpdata$xtmp[meta$ywrapline[[i]][[j]]$dominant_left_upper+1],
tmpdata$yscaled[meta$ywrapline[[i]][[j]]$dominant_left_upper+1],
meta$cutbound$orig[[tmpvargroup]][tmpdata$ywrapgroup[meta$ywrapline[[i]][[j]]$dominant_left_upper+1]+1])
addpoints_right = data.frame()
meta$ywrapline[[i]][[j]]$data = rbind(meta$ywrapline[[i]][[j]]$data, addpoints_left, addpoints_right)
}
if (length(meta$ywrapline[[i]][[j]]$dominant_left_lower)){
addpoints_left = meta$ywrapline[[i]][[j]]$data[meta$ywrapline[[i]][[j]]$dominant_left_lower,c('xtmp','ytmp'),drop=FALSE]
addpoints_left$id = meta$ywrapline[[i]][[j]]$data$id[meta$ywrapline[[i]][[j]]$dominant_left_lower+1]
addpoints_left$xtmp = crosspoint_x(tmpdata$xtmp[meta$ywrapline[[i]][[j]]$dominant_left_lower],
tmpdata$yscaled[meta$ywrapline[[i]][[j]]$dominant_left_lower],
tmpdata$xtmp[meta$ywrapline[[i]][[j]]$dominant_left_lower+1],
tmpdata$yscaled[meta$ywrapline[[i]][[j]]$dominant_left_lower+1],
meta$cutbound$orig[[tmpvargroup]][tmpdata$ywrapgroup[meta$ywrapline[[i]][[j]]$dominant_left_lower+1]])
addpoints_right = data.frame()
meta$ywrapline[[i]][[j]]$data = rbind(meta$ywrapline[[i]][[j]]$data, addpoints_left, addpoints_right)
}
if (length(meta$ywrapline[[i]][[j]]$dominant_right_upper)){
addpoints_right = meta$ywrapline[[i]][[j]]$data[meta$ywrapline[[i]][[j]]$dominant_right_upper,c('xtmp','ytmp','id'),drop=FALSE]
addpoints_right$xtmp = crosspoint_x(tmpdata$xtmp[meta$ywrapline[[i]][[j]]$dominant_right_upper],
tmpdata$yscaled[meta$ywrapline[[i]][[j]]$dominant_right_upper],
tmpdata$xtmp[meta$ywrapline[[i]][[j]]$dominant_right_upper-1],
tmpdata$yscaled[meta$ywrapline[[i]][[j]]$dominant_right_upper-1],
meta$cutbound$orig[[tmpvargroup]][tmpdata$ywrapgroup[meta$ywrapline[[i]][[j]]$dominant_right_upper-1]+1])
addpoints_left = data.frame()
meta$ywrapline[[i]][[j]]$data = rbind(meta$ywrapline[[i]][[j]]$data, addpoints_left, addpoints_right)
}
if (length(meta$ywrapline[[i]][[j]]$dominant_right_lower)){
addpoints_right = meta$ywrapline[[i]][[j]]$data[meta$ywrapline[[i]][[j]]$dominant_right_lower,c('xtmp','ytmp','id'),drop=FALSE]
addpoints_right$xtmp = crosspoint_x(tmpdata$xtmp[meta$ywrapline[[i]][[j]]$dominant_right_lower],
tmpdata$yscaled[meta$ywrapline[[i]][[j]]$dominant_right_lower],
tmpdata$xtmp[meta$ywrapline[[i]][[j]]$dominant_right_lower-1],
tmpdata$yscaled[meta$ywrapline[[i]][[j]]$dominant_right_lower-1],
meta$cutbound$orig[[tmpvargroup]][tmpdata$ywrapgroup[meta$ywrapline[[i]][[j]]$dominant_right_lower-1]])
addpoints_left = data.frame()
meta$ywrapline[[i]][[j]]$data = rbind(meta$ywrapline[[i]][[j]]$data, addpoints_left, addpoints_right)
}
if (length(meta$ywrapline[[i]][[j]]$recessive_up)){
addpoints_left = meta$ywrapline[[i]][[j]]$data[meta$ywrapline[[i]][[j]]$recessive_up,c('xtmp','ytmp','id'),drop=FALSE]
addpoints_left$xtmp = crosspoint_x(tmpdata$xtmp[meta$ywrapline[[i]][[j]]$recessive_up],
tmpdata$yscaled[meta$ywrapline[[i]][[j]]$recessive_up],
tmpdata$xtmp[meta$ywrapline[[i]][[j]]$recessive_up+1],
tmpdata$yscaled[meta$ywrapline[[i]][[j]]$recessive_up+1],
meta$cutbound$orig[[tmpvargroup]][j])
addpoints_right = meta$ywrapline[[i]][[j]]$data[meta$ywrapline[[i]][[j]]$recessive_up+1,c('xtmp','ytmp','id'),drop=FALSE]
addpoints_right$xtmp = crosspoint_x(tmpdata$xtmp[meta$ywrapline[[i]][[j]]$recessive_up],
tmpdata$yscaled[meta$ywrapline[[i]][[j]]$recessive_up],
tmpdata$xtmp[meta$ywrapline[[i]][[j]]$recessive_up+1],
tmpdata$yscaled[meta$ywrapline[[i]][[j]]$recessive_up+1],
meta$cutbound$orig[[tmpvargroup]][j+1])
meta$ywrapline[[i]][[j]]$data = rbind(meta$ywrapline[[i]][[j]]$data, addpoints_left, addpoints_right)
}
if (length(meta$ywrapline[[i]][[j]]$recessive_dn)){
addpoints_left = meta$ywrapline[[i]][[j]]$data[meta$ywrapline[[i]][[j]]$recessive_dn,c('xtmp','ytmp','id'),drop=FALSE]
addpoints_left$xtmp = crosspoint_x(tmpdata$xtmp[meta$ywrapline[[i]][[j]]$recessive_dn],
tmpdata$yscaled[meta$ywrapline[[i]][[j]]$recessive_dn],
tmpdata$xtmp[meta$ywrapline[[i]][[j]]$recessive_dn+1],
tmpdata$yscaled[meta$ywrapline[[i]][[j]]$recessive_dn+1],
meta$cutbound$orig[[tmpvargroup]][j+1])
addpoints_right = meta$ywrapline[[i]][[j]]$data[meta$ywrapline[[i]][[j]]$recessive_dn+1,c('xtmp','ytmp','id'),drop=FALSE]
addpoints_right$xtmp = crosspoint_x(tmpdata$xtmp[meta$ywrapline[[i]][[j]]$recessive_dn],
tmpdata$yscaled[meta$ywrapline[[i]][[j]]$recessive_dn],
tmpdata$xtmp[meta$ywrapline[[i]][[j]]$recessive_dn+1],
tmpdata$yscaled[meta$ywrapline[[i]][[j]]$recessive_dn+1],
meta$cutbound$orig[[tmpvargroup]][j])
meta$ywrapline[[i]][[j]]$data = rbind(meta$ywrapline[[i]][[j]]$data, addpoints_left, addpoints_right)
}
meta$ywrapline[[i]][[j]]$data = meta$ywrapline[[i]][[j]]$data[order(meta$ywrapline[[i]][[j]]$data$xtmp),]
}
}
# update the settings
update_meta_group(meta)
update_meta_xwrap_color(meta,data)
meta$limits[3:4] = extend_ranges(range(c(meta$data$ytmp,if(meta$ngroup$y==1 & meta$ngroup$id==1){diff(range(ytmp))*meta$steplen$yzoom}),na.rm=TRUE))
meta_yaxis(meta)
}
# 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)
}
# aspect ratio
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)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.