R/qdensity.R

In ggobi/cranvas: Interactive statistical graphics based on Qt

##' Draw a univariate density plot
##' 
##' Draw a univariate density plot, with a rug plot underneath.
##' 
##' Common interactions are documented in \code{\link{common_key_press}}. 
##' Specific interactions include: Arrow \code{Up}/\code{Down} in-/de-creases 
##' size of points; Arrow \code{Left}/\code{Right} de-/in-creases binwidth for 
##' density; Key \code{Z} toggle zoom on/off (default is off); mouse click & 
##' drag will specify a zoom window.
##' 
##' Note there are two short tickmarks in the plot denoting the binwidth.
##' @param x variable name which designates variable displayed on the horizontal
##'   axis
##' @inheritParams qbar
##' @inheritParams qhist
##' @export
##' @family plots
##' @example inst/examples/qdensity-ex.R
qdensity <- function(x, data, binwidth = NULL, main = '',
                     xlim = NULL, ylim = NULL, xlab = NULL, ylab = NULL) {

    ################################
    # data processing & parameters #
    ################################

    data = check_data(data)
    b = brush(data)
    s = attr(data, 'Scales')
    z = as.list(match.call()[-1])
    ## initialize meta
    meta = Dens.meta$new(xvar = as.character(z$x), active = TRUE, alpha = .5, 
                         main = main, minor = 'xy', samesize = near_constant(data$.size))
    ## set default xlab if not provided
    if (is.null(xlab)) meta$xlab = meta$xvar

    ## reorder the points according to color/border for drawing speed
    compute_order = function() {
        ord = order(data$.color, data$.border) # the ideal order to draw
        names(ord) = seq(nrow(data))    # orignal order is in names
        meta$order = ord
    }
    compute_order()

    ## compute coordinates/axes-related stuff
    # meta$x: data
    # y.all: density values
    compute_coords = function() {
        meta$x = data[, meta$xvar]
        if (!length(meta$binwidth)) {
            meta$binwidth <- if (is.null(binwidth)) {
                density(meta$x)$bw  # Get density to estimate the best binwidth
            } else binwidth
        }
        idx = visible(data)
        grp = data$.color
        if (length(nm <- as.character(s$color$variable)) && (nm %in% names(data))) {
            grp = if (is.factor(data[, nm])) {
                data$.color
            } else rep('gray15', length(meta$x))
        }
        ## densities by color groups
        meta$dxy = lapply(split(meta$x[idx], grp[idx]), function(v) {
            density(v, meta$binwidth)[c('x', 'y')]
        })
        y.all = as.vector(sapply(meta$dxy, `[[`, 'y')) # all density values
        meta$xat = axis_loc(meta$x[idx])
        meta$yat = axis_loc(y.all)
        meta$xlabels = format(meta$xat)
        meta$ylabels = format(meta$yat)
        meta$xlab = if (is.null(xlab)) meta$xvar else xlab
        meta$ylab = if (is.null(ylab)) "Density" else ylab
        y.all = y.all * 100 + 0.00  # due to Qt imprecision bug
        meta$yat = meta$yat * 100 + 0.00
        r = cbind(if (is.null(xlim)) range(meta$x[idx], na.rm = TRUE, finite = TRUE) else xlim,
                  if (is.null(ylim)) c(0.00, max(y.all, na.rm = TRUE)) else ylim * 100 + 0.00)
        meta$limits = extend_ranges(r)
        meta$x = meta$x[meta$order]
        meta$y = diff(meta$limits[, 2]) / 80  # ugly clipping bug
    }
    compute_coords()

    ## aesthetics (colors)
    compute_aes = function() {
        idx = !visible(data)[meta$order]
        meta$color = data$.color[meta$order]; meta$border = data$.border[meta$order]
        meta$color[idx] = NA; meta$border[idx] = NA
        meta$size = data$.size[meta$order]; meta$size[idx] = NA
    }
    compute_aes()

    ## initialize brush size (1/15 of the layer size)
    meta$brush.size = c(1, -1) * apply(meta$limits, 2, diff) / 15

    ## draw points & density
    main_draw = function(layer, painter) {
        if (meta$samesize) {
            qdrawGlyph(painter, qglyphSegment(data$.size[1], pi/2), meta$x, meta$y,
                       stroke = alpha(meta$border, meta$alpha), fill = alpha(meta$color, meta$alpha))
        } else {
            qdrawCircle(painter, meta$x, meta$y, r = meta$size,
                        stroke = alpha(meta$border, meta$alpha), fill = alpha(meta$color, meta$alpha))
        }
    }
    ## density lines
    line_draw = function(layer, painter) {
        for (i in names(meta$dxy)) {
            xy = meta$dxy[[i]]
            qlineWidth(painter) = 2
            qdrawLine(painter, x = xy$x, y = xy$y * 100, stroke = i)
        }
        bin.x = meta$xat[1] + c(0, 1) * meta$binwidth
        bin.y = meta$yat[1] + c(0, 1) * meta$y
        qdrawSegment(painter, bin.x, bin.y[1], bin.x, bin.y[2], stroke = 'gray15')
    }
    ## draw brushed points
    brush_draw = function(layer, painter) {
        idx = visible(data) & selected(data)
        if (any(idx)) {
            qlineWidth(painter) = 3
            if (meta$samesize) {
                qdrawGlyph(painter, qglyphSegment(meta$size[1], pi/2),
                           data[idx, meta$xvar], meta$y, stroke = b$color, fill = b$color)
            } else {
                qdrawCircle(painter, data[idx, meta$xvar], meta$y,
                            r = b$size * data$.size[idx], stroke = b$color, fill = b$color)
            }
            dxy = density(data[idx, meta$xvar], meta$binwidth)
            qdrawLine(painter, dxy$x, dxy$y / max(dxy$y) * max(meta$yat), stroke = b$color)
        }
        draw_brush(layer, painter, data, meta)
    }

    ## events
    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) + 1
        if (length(hits)) {
            hits = intersect(meta$order[as.character(hits)],  which(visible(data)))
        }
        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)
    }
    key_press = function(layer, event) {
        common_key_press(layer, event, data, meta)
        shift = shift_on(event)
        if (shift && length(i <- which(match_key(c('Left', 'Right', 'Up', 'Down'))))) {
            j = c(1, 1, 2, 2)[i]; k = c(1, -1, -1, 1)[i]
            meta$limits[, j] = extend_ranges(meta$limits[, j], k * c(1, -1) * 0.02)
        } else if (length(i <- which(match_key(c('Up', 'Down'))))) {
            ## change size
            data$.size = pmax(0.1, c(1.1, 0.9)[i] * data$.size)
        } else if (length(i <- which(match_key(c('Left', 'Right'))))) {
            meta$binwidth = c(.95, 1.05)[i] * meta$binwidth
        }
    }
    key_release = function(layer, event) {
        common_key_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
      meta$limits[, 1] = extend_ranges(
        meta$limits[, 1], -sign(event$delta()) * 0.1 * c(p[1], 1 - p[1])
      )
    }
    identify_hover = function(layer, event) {
        if (!b$identify) return()
        b$cursor = 2L
        meta$pos = as.numeric(event$pos())
        hits = layer$locate(identify_rect(meta)) + 1
        meta$identified = intersect(meta$order[as.character(hits)], which(visible(data)))
        qupdate(layer.identify)
    }
    identify_draw = function(layer, painter) {
        if (!b$identify || !length(idx <- meta$identified)) return()
        meta$identify.labels = sprintf('row id: %s\n%s: %s',
                                       paste(rownames(data)[idx], collapse = ', '),
                                       meta$xvar, paste(meta$x[idx], collapse = ', '))
        draw_identify(layer, painter, data, meta)
        if (meta$samesize) {
            qdrawGlyph(painter, qglyphCircle(r = 2 * b$size * data$.size[1]),
                       data[idx, meta$xvar], meta$y, stroke = b$color, fill = NA)
        } else {
            qdrawCircle(painter, data[idx, meta$xvar], meta$y, r = b$size * meta$size,
                        stroke = b$color, fill = NA)
        }
    }

    ###################
    # draw the canvas #
    ###################
    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.lines = qlayer(paintFun = line_draw, limits = qrect(meta$limits), clip = TRUE)
    layer.brush = qlayer(paintFun = brush_draw, limits = qrect(meta$limits), clip = TRUE)
    layer.identify = qlayer(paintFun = identify_draw, 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.lines
    layer.root[1, 2] = layer.brush
    layer.root[1, 2] = layer.identify
    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)

    ## finally create the view and set window title
    view = qplotView(scene = scene)
    view$setWindowTitle(paste("Density plot:", meta$xvar))
    meta$xvarChanged$connect(function() {
        view$setWindowTitle(paste("Density plot:", meta$xvar))
    })
    view$resize(480, 480)

    ## listeners on the data (which column updates which layer(s))
    d.idx = add_listener(data, function(i, j) {
        idx = which(j == c(meta$xvar, '.brushed', '.color', '.border'))
        if (length(idx) < 1) {
            compute_coords(); compute_aes()
            meta$samesize = near_constant(data$.size)
            qupdate(layer.grid); qupdate(layer.xaxis); qupdate(layer.yaxis)
            layer.main$invalidateIndex(); qupdate(layer.main)
            return()
        } else idx = c(1, 2, 3, 3)[idx]
        switch(idx, compute_coords(), qupdate(layer.brush), {
            compute_order(); compute_aes(); qupdate(layer.main)
        })
    })

    ## when layer is destroyed, remove the listener from data
    qconnect(layer.main, 'destroyed', function(x) {
        ## b$colorChanged$disconnect(b.idx)
        remove_listener(data, d.idx)
    })

    ## when b$cursor is changed, update cursor on screen
    b$cursorChanged$connect(function() {
        set_cursor(view, b$cursor)
    })

    ## these layers have the same limits from meta$limits
    sync_limits(meta, layer.main, layer.lines, layer.brush, layer.identify)

    ## simulate brushing
    meta$manual.brush = function(pos) {
        brush_mouse_move(layer = layer.main, event = list(pos = function() pos))
    }

    meta$binwidthChanged$connect(function () {
        compute_coords(); layer.main$invalidateIndex()
    })

    ## attach meta to the returned value (for post-processing or debugging)
    attr(view, 'meta') = meta
    view
}

Dens.meta = setRefClass("Dens_meta", contains = "CommonMeta",
                        fields = properties(
                            list(xvar = 'character', order = 'numeric',
                                 x = 'numeric', y = 'numeric', binwidth = 'numeric',
                                 dxy = 'list', asp = 'numeric', samesize = 'logical')
                            ))