#' Draw a histogram or a spine plot
#'
#' Draw an interactive histogram or spine plot based on a continuous variable,
#' optionally split by a categorical variable. It supports some common keyboard
#' interactions (see \code{\link{common_key_press}}) as well as other
#' interactions specific to histograms and spine plots.
#'
#' The splitting variable is usually specified in \code{\link{qdata}} as the
#' \code{color} or \code{border} argument; if it is present, each bar in the
#' plot will be split into categories.
#'
#' Arrow keys can be used to change the binwidth as well as the breakpoints in
#' the plot. Up and Down can increase and decrease the binwidth respectively;
#' Left and Right can move the breakpoints of the bins to the left (smaller) or
#' right (larger). Mouse wheel helps zoom in/out of the plot.
#'
#' In the identify mode, the breakpoints of the bin(s) as well as counts and
#' proportion of cases in the bin(s) are shown as text labels in the plot.
#'
#' The function \code{\link{qspine}} is a short-hand version of \code{qhist(...,
#' spine = TRUE)}.
#' @param x the name of the numeric variable to be used to draw the histogram or
#' spine plot
#' @param bins the desired number of bins, default=30, overridden by binwidth if provided
#' @param binwidth the bin width (\code{range(x) / bins} by default)
#' @param breaks sets break points, mostly for use with the tour
#' @param ybreaks sets vertical axis, mostly for use with the tour
#' @param freq draw the frequencies (\code{TRUE}) or densities (\code{FALSE})
#' (only applies to histogram)
#' @param spine if \code{TRUE}, draw a spine plot (bar widths proportional to
#' counts instead of being equal)
#' @param ... arguments passed to \code{\link{qhist}}
#' @inheritParams qbar
#' @return A histogram or a spine plot
#' @author Yihui Xie <\url{http://yihui.name}>
#' @export
#' @family plots
#' @example inst/examples/qhist-ex.R
qhist = function(x, data, bins = 30, binwidth = NULL, breaks = NULL, ybreaks = NULL,
freq = TRUE, main = '',
horizontal = FALSE, spine = FALSE, xlim = NULL, ylim = NULL,
xlab = NULL, ylab = NULL) {
data = check_data(data)
# Do we need to check if bins and binwidth are compatible?
b = brush(data)
b$select.only = TRUE; b$draw.brush = FALSE # a selection brush
cueOn = FALSE
if (!is.null(ybreaks)) ylim = range(ybreaks)
meta = Hist.meta$new(
var = as.character(as.list(match.call()[-1])$x), freq = freq, alpha = 1,
horizontal = horizontal, main = main, active = TRUE, standardize = spine,
spine = spine, multiplier = 1
)
initialize_bins = function() {
d = data[, meta$var]
## temporarily steal from hadley's densityvis
if (!is.null(breaks)) {
meta$breaks <- breaks
}
else {
if (is.null(xlim))
r = range(d, na.rm = TRUE, finite = TRUE)
else
r = xlim
if (diff(r) < 1e-7) {
meta$breaks = r
meta$binwidth = diff(r)
}
else {
if (is.null(binwidth))
meta$binwidth = diff(r) / bins
else
meta$binwidth = binwidth
if (is.null(xlim)) # Only adjust bins to center on midpoint if limits not provided
meta$breaks = seq(r[1], r[2] + meta$binwidth, meta$binwidth) - meta$binwidth / 2
else
meta$breaks = seq(r[1], r[2] + meta$binwidth, meta$binwidth)
}
}
}
resize_bins = function() {
d = data[, meta$var]
## temporarily steal from hadley's densityvis
if (is.null(xlim))
r = range(d, na.rm = TRUE, finite = TRUE)
else
r = xlim
if (diff(r) < 1e-7) {
meta$breaks = r
meta$binwidth = diff(r)
} else {
#if (default) meta$binwidth = if (is.null(binwidth)) diff(r) / bins else binwidth
meta$breaks = seq(r[1], r[2] + meta$binwidth, meta$binwidth) - meta$binwidth / 2
}
}
initialize_bins()
compute_coords = function(reset = TRUE) {
if (meta$spine) meta$freq = meta$standardize = TRUE else meta$standardize = FALSE
idx = visible(data)
meta$value = cut(data[, meta$var], breaks = meta$breaks, include.lowest = TRUE)
nb = length(meta$breaks)
meta$nlevel = nb - 1
.find_split_var(data, meta)
tmp = table(meta$value[idx], meta$value2[idx])
if (ncol(tmp) > 1) tmp = t(apply(tmp, 1, cumsum))
if (!meta$freq) tmp = tmp / (sum(idx) * meta$binwidth)
if (meta$standardize) tmp = tmp / tmp[, meta$nlevel2, drop = ncol(tmp) > 1]
tmp[!is.finite(tmp)] = 0 # consider division by 0
meta$y = c(tmp)
meta$x = rep(meta$breaks[-1] - meta$binwidth / 2, meta$nlevel2)
if (reset) { # Should only make axes pretty if breaks not provided
if (!is.null(breaks)) {
xlim <- range(breaks)
meta$xat = seq(xlim[1], xlim[2], length.out=5)
}
else {
if (!is.null(xlim))
meta$xat = seq(xlim[1], xlim[2], length.out=5)
else # (is.null(xlim))
meta$xat = axis_loc(meta$breaks)
#else {
#meta$xat = meta$breaks
# meta$xat = seq(xlim[1], xlim[2], length.out=5)
}
if (!is.null(ybreaks)) {
meta$yat = ybreaks
}
else {
if (!is.null(ylim))
meta$yat = seq(ylim[1], ylim[2], length.out=5)
else # (is.null(xlim))
meta$yat = axis_loc(c(0, meta$y))
#else {
#meta$xat = meta$breaks
# meta$xat = seq(xlim[1], xlim[2], length.out=5)
}
# if (is.null(ylim))
# meta$yat = axis_loc(c(0, meta$y))
# else
# meta$yat = seq(ylim[1], ylim[2], length.out=5)
meta$xlabels = format(meta$xat)
meta$ylabels = format(meta$yat)
meta$xlab = if (is.null(xlab)) meta$var else xlab
meta$ylab = if (is.null(ylab)) {
if (meta$spine) 'Proportion' else if (meta$freq) 'Frequency' else 'Density'
} else ylab
cat("making axes","\n")
}
if (meta$spine) {
meta$xright = cumsum(table(meta$value[idx])) / sum(idx) # [0,1], prop counts
meta$xleft = c(0, meta$xright[-meta$nlevel])
if (reset) {
meta$xat = c(0, meta$xright)
meta$xlabels = unname(tapply(formatC(meta$breaks), meta$xat, function(x) {
if (length(x) <= 1) x else {
sprintf('%s%s(%s)', x[1], if (meta$horizontal) '' else '\n', x[length(x)])
}
}))
meta$xat = unique(meta$xat)
}
meta$xleft = rep(meta$xleft, meta$nlevel2)
meta$xright = rep(meta$xright, meta$nlevel2)
}
else {
cat("here ",nb, meta$nlevel2,"\n")
meta$xleft = rep(meta$breaks[-nb], meta$nlevel2)
meta$xright = rep(meta$breaks[-1], meta$nlevel2)
}
meta$ybottom = c(cbind(0, tmp[, -meta$nlevel2, drop = FALSE])); meta$ytop = meta$y
if (!freq && max(meta$ytop) < 0.5) {
## there seems to be an ugly bug in qt: rectangles with small height not drawn
meta$multiplier = k = 1 / max(meta$ytop) * 10
meta$ybottom = meta$ybottom * k; meta$ytop = meta$ytop * k
if (reset) meta$yat = meta$yat * k
#if (!is.null(ylim)) ylim = ylim * k
}
if (reset) { # Only extend ranges if limits not given in initial call
meta$limits <- cbind(if (is.null(xlim))
extend_ranges(range(c(meta$xleft, meta$xright))) else xlim,
if (is.null(ylim))
extend_ranges(range(c(meta$ybottom, meta$ytop))) else ylim)
}
meta$minor = ifelse(meta$spine, ifelse(meta$horizontal, 'x', 'y'), 'xy')
}
#compute_coords(reset=FALSE)
compute_coords()
compute_colors = function() {
.bar_compute_colors(data, meta)
}
compute_colors()
flip_coords = function(bar.only = FALSE) {
.bar_flip_coords(data, meta, bar.only)
}
flip_coords()
meta$brush.size = c(1, -1) * apply(meta$limits, 2, diff) / 15
main_draw = function(layer, painter) {
.bar_draw_main(layer, painter, meta)
}
brush_draw = function(layer, painter) {
.bar_draw_brush(layer, painter, data, meta)
if (meta$horizontal) {
y0 = min(meta$ybottom); x0 = x1 = min(meta$xleft); y1 = max(meta$ytop)
} else {
x0 = min(meta$xleft); y0 = y1 = min(meta$ybottom); x1 = max(meta$xright)
}
qdrawSegment(painter, x0, y0, x1, y1) # draw a baseline
}
brush_mouse_press = function(layer, event) {
common_mouse_press(layer, event, data, meta)
}
brush_mouse_move = function(layer, event) {
rect = qrect(update_brush_size(meta, event))
hits = layer$locate(rect)
if (length(hits)) {
hits = .find_intersect(meta$value, hits, meta$nlevel)
}
selected(data) = mode_selection(selected(data), hits, mode = b$mode)
common_mouse_move(layer, event, data, meta)
}
brush_mouse_release = function(layer, event) {
brush_mouse_move(layer, event)
common_mouse_release(layer, event, data, meta)
}
mouse_wheel = function(layer, event) {
pos = as.numeric(event$pos())
lim = meta$limits
p = (pos - lim[1, ]) / (lim[2, ] - lim[1, ]) # proportions to left/bottom
s = if (horizontal) c(0, 0, p[2], 1 - p[2]) else c(p[1], 1 - p[1], 0, 0)
meta$limits = extend_ranges(meta$limits, -sign(event$delta()) * 0.1 * s)
}
shift_anchor = function(shift) {
brk = meta$breaks
r = range(data[, meta$var], na.rm = TRUE, finite = TRUE)
brk = brk + shift # shift by +/-(2% bin)
if (min(brk) > r[1]) brk = c(brk[1] - meta$binwidth, brk)
if (max(brk) < r[2]) brk = c(brk, tail(brk, 1) + meta$binwidth)
if (length(brk) <= 2) return()
## see if two breakpoints both < min or > max (remove one if so)
if (all(head(brk, 2) <= r[1])) {
brk = brk[-1]
message('removed one left-most bin because it does not contain data...')
}
if (all(tail(brk, 2) >= r[2])) {
brk = brk[-length(brk)]
message('removed one right-most bin because it does not contain data...')
}
return(brk)
}
key_press = function(layer, event) {
common_key_press(layer, event, data, meta)
if (length(i <- which(match_key(c('Up', 'Down'))))) {
meta$binwidth = c(1.05, 0.95)[i] * meta$binwidth # larger/smaller bins
if (meta$binwidth < ifelse(length(meta$binmin), meta$binmin, 1e-7)) {
meta$binwidth = meta$binmin
message('binwidth too small!')
}
resize_bins() # use new binwidth
layer.cues$invalidateIndex()
return()
} else if (length(i <- which(match_key(c('Left', 'Right'))))) {
shift = c(-1, 1)[i] * meta$binwidth / 50 # shift by +/-(2% bin)
meta$breaks = shift_anchor(shift)
layer.cues$invalidateIndex()
return()
}
}
key_release = function(layer, event) {
common_key_release(layer, event, data, meta)
}
identify_hover = function(layer, event) {
if (!b$identify) return()
b$cursor = 2L
meta$pos = as.numeric(event$pos())
meta$identified = layer$locate(identify_rect(meta))
qupdate(layer.identify)
}
identify_draw = function(layer, painter) {
if (!b$identify || !length(idx <- meta$identified)) return()
k = .find_intersect(meta$value, idx, meta$nlevel)
meta$identify.labels = sprintf(
'bin: (%s]\ncount: %s/%s\nproportion: %.1f/%.1f%%',
paste(round(meta$breaks[range(idx %% meta$nlevel) + c(1, 2)], 1), collapse = ','),
sum(k & data$.brushed), sum(k), sum(k & data$.brushed)/sum(k)*100, mean(k) * 100
)
draw_identify(layer, painter, data, meta)
idx = idx + 1
qdrawRect(painter, meta$xleft[idx], meta$ybottom[idx], meta$xright[idx],
meta$ytop[idx], stroke = b$color, fill = NA)
}
cue_mouse_move = function(layer, event) {
pos = as.numeric(event$pos())
eps = 2*pixelToXY(layer.main, meta$limits, 1,1)
rect = qrect(pos[1]-eps[1], pos[2]-eps[2], pos[1]+eps[1], pos[2]+eps[2])
hits = layer$locate(rect)
if (length(hits)) {
b$cursor = 18L # ClosedHandCursor
if (hits[1]==0) {
shift = pos[1] - meta$xleft[1]
# message(sprintf('anchor: %f', pos[1]))
meta$breaks = shift_anchor(shift)
layer.cues$invalidateIndex()
qupdate(layer.cues)
return()
}
if (hits[1]==1) {
meta$binwidth = pos[1] - meta$xleft[1] # larger/smaller bin width
# message(sprintf('binwidth: %f', meta$binwidth))
if (meta$binwidth < ifelse(length(meta$binmin), meta$binmin, 1e-7)) {
meta$binwidth = meta$binmin
message('binwidth too small!')
}
resize_bins() # use new binwidth
layer.cues$invalidateIndex()
qupdate(layer.cues)
return()
}
} else {
# pass mouse move on, if cue is not being moved
if (!cueOn) brush_mouse_move(layer.main, event)
}
}
cue_hover = function(layer, event) {
pos = as.numeric(event$pos())
eps = 2*pixelToXY(layer.main, meta$limits, 1,1)
rect = qrect(pos[1]-eps[1], pos[2]-eps[2], pos[1]+eps[1], pos[2]+eps[2])
hits = layer.cues$locate(rect)
# meta$pos = as.numeric(event$pos())
# hits = layer.cues$locate(identify_rect(meta))
if (length(hits > 0)) {
# change cursor shape
if (hits[1] == 0) b$cursor = 17L # OpenHandCursor # anchor
if (hits[1] == 1) b$cursor = 17L # OpenHandCursor # binwidth
if (hits[1] == 2) b$cursor = 5L # ArrowVertCursor # binheight
} else {
# pass hover on and reverse any changes to the cursor
b$cursor = 2L # CrossCursor
identify_hover(layer.main, event)
}
}
pixelToXY = function(layer, limits, px, py) {
dx = px/layer.main$geometry$width()*diff(range(limits[,1]))
dy = py/layer.main$geometry$height()*diff(range(limits[,2]))
c(dx,dy)
}
cue_draw = function(layer, painter) {
ybottom = meta$limits[1,2]
ytop = meta$limits[2,2]
eps = pixelToXY(layer, meta$limits, 1,1)
#print(ytop)
anchorCue = c(meta$xleft[1]-eps[1], meta$xleft[1]+eps[1], 0.25*ybottom, 0.75*ybottom)
binwidthCue = c(meta$xleft[2]-eps[1], meta$xleft[2]+eps[1], 0.25*ybottom, 0.75*ybottom)
binheightCue = c(meta$limits[1,1], meta$limits[2,1], ytop-10*eps[2], ytop)
qdrawRect(painter, anchorCue[1], anchorCue[3], anchorCue[2], anchorCue[4], stroke="grey50", fill="grey50")
qdrawRect(painter, binwidthCue[1], binwidthCue[3], binwidthCue[2], binwidthCue[4], stroke="grey50", fill="grey50")
color = rgb(t(col2rgb("grey50"))/255, alpha=0.2)
qdrawRect(painter, binheightCue[1], binheightCue[3], binheightCue[2], binheightCue[4], stroke=color, fill=color)
}
cue_mouse_press = function(layer, event) {
pos = as.numeric(event$pos())
eps = 2*pixelToXY(layer, meta$limits, 1,1)
rect = qrect(pos[1]-eps[1], pos[2]-eps[2], pos[1]+eps[1], pos[2]+eps[2])
hits = layer$locate(rect)
if (length(hits)) {
cueOn <<- TRUE
if (hits[1] == 2) { #adjust vertical height to current maximum bin height
meta$limits[,2] =
extend_ranges(c(meta$ybottom, meta$ytop))
meta$yat = axis_loc(c(0, meta$limits[2,2]))
meta$ylabels = format(meta$yat)
}
}
common_mouse_press(layer.main, event, data, meta)
}
cue_mouse_release = function(layer, event) {
if (cueOn) cueOn <<- FALSE
else brush_mouse_release(layer.main, event)
}
scene = qscene()
layer.root = qlayer(scene)
layer.main = qlayer(
paintFun = main_draw,
mousePressFun = brush_mouse_press, mouseReleaseFun = brush_mouse_release,
mouseMoveFun = brush_mouse_move, hoverMoveFun = identify_hover,
keyPressFun = key_press, keyReleaseFun = key_release, wheelFun = mouse_wheel,
focusInFun = function(layer, event) {
common_focus_in(layer, event, data, meta)
}, focusOutFun = function(layer, event) {
common_focus_out(layer, event, data, meta)
},
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.cues = qlayer(
paintFun = cue_draw,
mousePressFun = cue_mouse_press, mouseReleaseFun = cue_mouse_release,
mouseMoveFun = cue_mouse_move, hoverMoveFun = cue_hover,
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)
},
limits = qrect(meta$limits)
)
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.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
layer.root[1, 2] = layer.main
layer.root[1, 2] = layer.brush
layer.root[1, 2] = layer.identify
layer.root[1, 2] = layer.cues
layer.root[1, 3] = qlayer()
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()
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);
view = qplotView(scene = scene)
view$setWindowTitle(paste(ifelse(meta$spine, "Spine plot:", "Histogram:"), meta$var))
meta$varChanged$connect(function() {
view$setWindowTitle(paste(ifelse(meta$spine, "Spine plot:", "Histogram:"), meta$var))
})
view$resize(480, 480)
d.idx = add_listener(data, function(i, j) {
idx = which(j == c(meta$var, '.brushed', '.color', '.border'))
if (length(idx) < 1) { # DI SAYS: why do bins need to be recalculated here???
compute_coords(); compute_colors(); flip_coords()
qupdate(layer.grid); qupdate(layer.xaxis); qupdate(layer.yaxis)
layer.main$invalidateIndex(); qupdate(layer.main)
return()
} else if (idx == 4) idx = 3
switch(idx, initialize_bins(), qupdate(layer.brush), {
compute_colors(); qupdate(layer.main)
}) # Not sure whether this is a resize or initialize bins
})
qconnect(layer.main, '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, layer.main, layer.brush, layer.identify, layer.cues) # sync limits
meta$manual.brush = function(pos) {
brush_mouse_move(layer = layer.main, event = list(pos = function() pos))
}
meta$breaksChanged$connect(function () {
compute_coords(reset = FALSE); compute_colors(); flip_coords(bar.only = TRUE)
layer.main$invalidateIndex()
qupdate(layer.grid); qupdate(layer.xaxis); qupdate(layer.yaxis); qupdate(layer.main)
})
attr(view, 'meta') = meta
view
}
Hist.meta = setRefClass("Hist_meta", contains = "CommonMeta",
fields = properties(
list(var = 'character', value = 'factor', var2 = 'character', value2 = 'factor',
x = 'numeric', y = 'numeric', breaks = 'numeric', horizontal = 'logical',
xleft = 'numeric', xright = 'numeric', ybottom = 'numeric', ytop = 'numeric',
split.type = 'character', spine = 'logical', nlevel = 'integer', nlevel2 = 'integer',
freq = 'logical', standardize = 'logical', binwidth = 'numeric',
multiplier = 'numeric', binmin = 'numeric', weight = 'character')
))
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.